Theory Sorted_List_Operations

section ‹\isaheader{Operations on sorted Lists}›
theory Sorted_List_Operations
imports Main Automatic_Refinement.Misc
begin 

fun inter_sorted :: "'a::{linorder} list  'a list  'a list" where
   "inter_sorted [] l2 = []"
 | "inter_sorted l1 [] = []"
 | "inter_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then (inter_sorted l1 (x2 # l2)) else 
     (if (x1 = x2) then x1 # (inter_sorted l1 l2) else inter_sorted (x1 # l1) l2))"

lemma inter_sorted_correct :
assumes l1_OK: "distinct l1  sorted l1"
assumes l2_OK: "distinct l2  sorted l2"
shows "distinct (inter_sorted l1 l2)  sorted (inter_sorted l1 l2)  
       set (inter_sorted l1 l2) = set l1  set l2"
using assms
proof (induct l1 arbitrary: l2) 
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2) 
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1  sorted l1"
                    and x1_nin_l1: "x1  set l1"
                    and x1_le: "x. x  set l1  x1  x"
    by (simp_all add: Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props 
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2  sorted l2"
                    and x2_nin_l2: "x2  set l2"
                    and x2_le: "x. x  set l2  x2  x"
    by (simp_all add: Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply (auto simp add: Ball_def)
        apply (metis linorder_not_le)
      done
    next
      case False note x2_le_x1 = this
      
      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis by (simp add: x1_eq_x2 Ball_def)
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
        show ?thesis 
          apply (auto simp add: x2_less_x1 Ball_def)
          apply (metis linorder_not_le x2_less_x1)
        done
      qed
    qed
  qed
qed

fun diff_sorted :: "'a::{linorder} list  'a list  'a list" where
   "diff_sorted [] l2 = []"
 | "diff_sorted l1 [] = l1"
 | "diff_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then x1 # (diff_sorted l1 (x2 # l2)) else 
     (if (x1 = x2) then (diff_sorted l1 l2) else diff_sorted (x1 # l1) l2))"

lemma diff_sorted_correct :
assumes l1_OK: "distinct l1  sorted l1"
assumes l2_OK: "distinct l2  sorted l2"
shows "distinct (diff_sorted l1 l2)  sorted (diff_sorted l1 l2)  
       set (diff_sorted l1 l2) = set l1 - set l2"
using assms
proof (induct l1 arbitrary: l2) 
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2) 
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1  sorted l1"
                    and x1_nin_l1: "x1  set l1"
                    and x1_le: "x. x  set l1  x1  x"
    by (simp_all add: Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props 
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2  sorted l2"
                    and x2_nin_l2: "x2  set l2"
                    and x2_le: "x. x  set l2  x2  x"
    by (simp_all add: Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply simp
        apply (simp add: Ball_def set_eq_iff)
        apply (metis linorder_not_le order_less_imp_not_eq2)
      done
    next
      case False note x2_le_x1 = this
      
      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis by (simp add: x1_eq_x2 Ball_def)
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from x2_less_x1 x1_le have x2_nin_l1: "x2  set l1"
           by (metis linorder_not_less)

        from ind_hyp_l2 x1_le x2_nin_l1
        show ?thesis 
          apply (simp add: x2_less_x1 x1_neq_x2 x2_le_x1 x1_nin_l1 Ball_def set_eq_iff)
          apply (metis x1_neq_x2)
        done
      qed
    qed
  qed
qed

fun subset_sorted :: "'a::{linorder} list  'a list  bool" where
   "subset_sorted [] l2 = True"
 | "subset_sorted (x1 # l1) [] = False"
 | "subset_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then False else 
     (if (x1 = x2) then (subset_sorted l1 l2) else subset_sorted (x1 # l1) l2))"

lemma subset_sorted_correct :
assumes l1_OK: "distinct l1  sorted l1"
assumes l2_OK: "distinct l2  sorted l2"
shows "subset_sorted l1 l2  set l1  set l2"
using assms
proof (induct l1 arbitrary: l2) 
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2) 
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1  sorted l1"
                    and x1_nin_l1: "x1  set l1"
                    and x1_le: "x. x  set l1  x1  x"
    by (simp_all add: Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props 
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2  sorted l2"
                    and x2_nin_l2: "x2  set l2"
                    and x2_le: "x. x  set l2  x2  x"
    by (simp_all add: Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply (auto simp add: Ball_def)
        apply (metis linorder_not_le)
      done
    next
      case False note x2_le_x1 = this
      
      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis 
          apply (simp add: subset_iff x1_eq_x2 Ball_def)
          apply metis
        done
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
        show ?thesis 
          apply (simp add: subset_iff x2_less_x1 Ball_def)
          apply (metis linorder_not_le x2_less_x1)
        done
      qed
    qed
  qed
qed

lemma set_eq_sorted_correct :
  assumes l1_OK: "distinct l1  sorted l1"
  assumes l2_OK: "distinct l2  sorted l2"
  shows "l1 = l2  set l1 = set l2"
  using assms
proof -
  have l12_eq: "l1 = l2  subset_sorted l1 l2  subset_sorted l2 l1"
  proof (induct l1 arbitrary: l2)
    case Nil thus ?case by (cases l2) auto
  next
    case (Cons x1 l1')
    note ind_hyp = Cons(1)

    show ?case
    proof (cases l2)
      case Nil thus ?thesis by simp
    next
      case (Cons x2 l2')
      thus ?thesis by (simp add: ind_hyp)
    qed
  qed
  also have "  ((set l1  set l2)  (set l2  set l1))"
    using subset_sorted_correct[OF l1_OK l2_OK] subset_sorted_correct[OF l2_OK l1_OK]
    by simp
  also have "  set l1 = set l2" by auto
  finally show ?thesis .
qed

fun memb_sorted where
   "memb_sorted [] x = False"
 | "memb_sorted (y # xs) x =
    (if (y < x) then memb_sorted xs x else (x = y))"

lemma memb_sorted_correct :
  "sorted xs  memb_sorted xs x  x  set xs"
by (induct xs) (auto simp add: Ball_def)


fun insertion_sort where
   "insertion_sort x [] = [x]"
 | "insertion_sort x (y # xs) =
    (if (y < x) then y # insertion_sort x xs else 
     (if (x = y) then y # xs else x # y # xs))"

lemma insertion_sort_correct :
  "sorted xs  distinct xs 
   distinct (insertion_sort x xs)  
   sorted (insertion_sort x xs) 
   set (insertion_sort x xs) = set (x # xs)"
by (induct xs) (auto simp add: Ball_def)

fun delete_sorted where
   "delete_sorted x [] = []"
 | "delete_sorted x (y # xs) =
    (if (y < x) then y # delete_sorted x xs else 
     (if (x = y) then xs else y # xs))"

lemma delete_sorted_correct :
  "sorted xs  distinct xs 
   distinct (delete_sorted x xs)  
   sorted (delete_sorted x xs) 
   set (delete_sorted x xs) = set xs - {x}"
apply (induct xs) 
apply simp
apply (simp add: Ball_def set_eq_iff)
apply (metis order_less_le)
done

end

Theory HashCode

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
                 Philipp Meyer <meyerphi@in.tum.de>
*)
section ‹\isaheader {The hashable Typeclass}›
theory HashCode
imports 
  Native_Word.Uint32 
begin

text_raw ‹\label{thy:HashCode}›

text ‹
  In this theory a typeclass of hashable types is established.
  For hashable types, there is a function hashcode›, that
  maps any entity of this type to an unsigned 32 bit word value.

  This theory defines the hashable typeclass and provides instantiations
  for a couple of standard types.
›

type_synonym
  hashcode = "uint32"

definition "nat_of_hashcode  nat_of_uint32"
definition "int_of_hashcode  int_of_uint32"
definition "integer_of_hashcode  integer_of_uint32"

class hashable =
  fixes hashcode :: "'a  hashcode"
  and def_hashmap_size :: "'a itself  nat"
  assumes def_hashmap_size: "1 < def_hashmap_size TYPE('a)"
begin
  definition bounded_hashcode :: "uint32  'a  uint32" where
    "bounded_hashcode n x = (hashcode x) mod n"
 
  lemma bounded_hashcode_bounds: "1 < n  bounded_hashcode n a < n"
    unfolding bounded_hashcode_def
    by (transfer, simp add: word_less_def uint_mod)

  definition bounded_hashcode_nat :: "nat  'a  nat" where
    "bounded_hashcode_nat n x = nat_of_hashcode (hashcode x) mod n"

  lemma bounded_hashcode_nat_bounds: "1 < n  bounded_hashcode_nat n a < n"
    unfolding bounded_hashcode_nat_def
    by transfer simp
end

instantiation unit :: hashable
begin
  definition [simp]: "hashcode (u :: unit) = 0"
  definition "def_hashmap_size = (λ_ :: unit itself. 2)"
  instance
    by (intro_classes)(simp_all add: def_hashmap_size_unit_def)
end

instantiation bool :: hashable
begin
  definition [simp]: "hashcode (b :: bool) = (if b then 1 else 0)"
  definition "def_hashmap_size = (λ_ :: bool itself. 2)"
  instance by (intro_classes)(simp_all add: def_hashmap_size_bool_def)
end

instantiation "int" :: hashable
begin
  definition [simp]: "hashcode (i :: int) = uint32_of_int i"
  definition "def_hashmap_size = (λ_ :: int itself. 16)"
  instance by(intro_classes)(simp_all add: def_hashmap_size_int_def)
end

instantiation "integer" :: hashable
begin
  definition [simp]: "hashcode (i :: integer) = Uint32 i"
  definition "def_hashmap_size = (λ_ :: integer itself. 16)"
  instance by(intro_classes)(simp_all add: def_hashmap_size_integer_def)
end

instantiation "nat" :: hashable
begin
  definition [simp]: "hashcode (n :: nat) = uint32_of_int (int n)"
  definition "def_hashmap_size = (λ_ :: nat itself. 16)"
  instance by(intro_classes)(simp_all add: def_hashmap_size_nat_def)
end

instantiation char :: hashable
begin
  definition [simp]: "hashcode (c :: char) == uint32_of_int (of_char c)"
  definition "def_hashmap_size = (λ_ :: char itself. 32)"
  instance by(intro_classes)(simp_all add: def_hashmap_size_char_def)
end

instantiation prod :: (hashable, hashable) hashable
begin
  definition "hashcode x == (hashcode (fst x) * 33 + hashcode (snd x))"
  definition "def_hashmap_size = (λ_ :: ('a × 'b) itself. def_hashmap_size TYPE('a) + def_hashmap_size TYPE('b))"
  instance using def_hashmap_size[where ?'a="'a"] def_hashmap_size[where ?'a="'b"]
    by(intro_classes)(simp_all add: def_hashmap_size_prod_def)
end

instantiation sum :: (hashable, hashable) hashable
begin
  definition "hashcode x == (case x of Inl a  2 * hashcode a | Inr b  2 * hashcode b + 1)"
  definition "def_hashmap_size = (λ_ :: ('a + 'b) itself. def_hashmap_size TYPE('a) + def_hashmap_size TYPE('b))"
  instance using def_hashmap_size[where ?'a="'a"] def_hashmap_size[where ?'a="'b"]
    by(intro_classes)(simp_all add: bounded_hashcode_bounds def_hashmap_size_sum_def split: sum.split)
end

instantiation list :: (hashable) hashable
begin
  definition "hashcode = foldl (λh x. h * 33 + hashcode x) 5381"
  definition "def_hashmap_size = (λ_ :: 'a list itself. 2 * def_hashmap_size TYPE('a))"
  instance
  proof
    from def_hashmap_size[where ?'a = "'a"]
    show "1 < def_hashmap_size TYPE('a list)"
      by(simp add: def_hashmap_size_list_def)
  qed
end

instantiation option :: (hashable) hashable
begin
  definition "hashcode opt = (case opt of None  0 | Some a  hashcode a + 1)"
  definition "def_hashmap_size = (λ_ :: 'a option itself. def_hashmap_size TYPE('a) + 1)"
  instance using def_hashmap_size[where ?'a = "'a"]
    by(intro_classes)(simp_all add: def_hashmap_size_option_def split: option.split)
end

lemma hashcode_option_simps [simp]:
  "hashcode None = 0"
  "hashcode (Some a) = 1 + hashcode a"
  by(simp_all add: hashcode_option_def)

lemma bounded_hashcode_option_simps [simp]:
  "bounded_hashcode n None = 0"
  "bounded_hashcode n (Some a) = (hashcode a + 1) mod n"
  by (simp_all add: bounded_hashcode_def ac_simps)

(*
lemma bounded_hashcode_option_simps [simp]:
  "bounded_hashcode n None = 0"
  "bounded_hashcode n (Some a) = (bounded_hashcode n a + 1) mod n"
  apply (simp_all add: bounded_hashcode_def, transfer, simp_all add: word_mod_def)
  apply (simp_all add: algebra_simps mod_add_right_eq)
*)

instantiation String.literal :: hashable
begin

definition hashcode_literal :: "String.literal  uint32" 
  where "hashcode_literal s = hashcode (String.explode s)"

definition def_hashmap_size_literal  :: "String.literal itself  nat"
  where "def_hashmap_size_literal _ = 10"

instance
  by standard (simp_all only: def_hashmap_size_literal_def)

end


hide_type (open) word

end

Theory Code_Target_ICF

section ‹Default Code Generator Setup for the Isabelle Collection Framework›
theory Code_Target_ICF
imports   
  "HOL-Library.Code_Target_Numeral"
  Native_Word.Code_Target_Bits_Int
begin

end

Theory SetIterator

(*  Title:       Iterators over Finite Sets
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section ‹\isaheader{Iterators over Finite Sets}›
theory SetIterator
imports 
  Automatic_Refinement.Misc 
  Automatic_Refinement.Foldi 
  (*"../../Refine_Monadic/Refine_Monadic"*)
begin

text ‹When reasoning about finite sets, it is often handy to be able to iterate over the elements
  of the set. If the finite set is represented by a list, the @{term fold} operation can be used.
  For general finite sets, the order of elements is not fixed though. Therefore, nondeterministic
  iterators are introduced in this theory.›

subsection ‹General Iterators›

type_synonym ('x,) set_iterator = "(bool)  ('x)    "

locale set_iterator_genord =
  fixes iti::"('x,) set_iterator" 
    and S0::"'x set" 
    and R::"'x  'x  bool"
  assumes foldli_transform:
    "l0. distinct l0  S0 = set l0  sorted_wrt R l0  iti = foldli l0"
begin
  text ‹Let's prove some trivial lemmata to show that the formalisation agrees with
          the view of iterators described above.›
  lemma set_iterator_weaken_R :
    "(x y. x  S0; y  S0; R x y  R' x y)  
             set_iterator_genord iti S0 R'"
    by (metis set_iterator_genord.intro foldli_transform sorted_wrt_mono_rel)

  lemma finite_S0 :
    shows "finite S0"
    by (metis finite_set foldli_transform)

  lemma iti_stop_rule_cond :
    assumes not_c: "¬(c σ)"
    shows "iti c f σ = σ"
  proof -
    from foldli_transform obtain l0 where l0_props:
      "iti c = foldli l0 c" by blast
    with foldli_not_cond [of c σ l0 f, OF not_c]
    show ?thesis by simp
  qed

  lemma iti_stop_rule_emp :
    assumes S0_emp: "S0 = {}"
    shows "iti c f σ = σ"
  proof -
    from foldli_transform obtain l0 where l0_props:
      "S0 = set l0" "iti c = foldli l0 c" by blast
    with foldli.simps(1) [of c f σ] S0_emp
    show ?thesis by simp
  qed

  text ‹Reducing everything to folding is cumbersome. Let's
          define a few high-level inference rules.›

  lemma iteratei_rule_P:
    assumes 
      "I S0 σ0"
      "S σ x.  c σ; x  S; I S σ; S  S0; 
                 yS - {x}. R x y; yS0 - S. R y x 
                  I (S - {x}) (f x σ)"
      "σ. I {} σ  P σ"
      "σ S.  S  S0; S  {}; ¬ c σ; I S σ;
               xS. yS0-S. R y x   P σ"
    shows "P (iti c f σ0)"
  proof -
    { fix P I σ0 f
      assume
        I: "I S0 σ0" and 
        R: "S σ x. c σ; x  S; I S σ; S  S0; yS-{x}. R x y  I (S - {x}) (f x σ)" and
        C1: "I {} (iti c f σ0)  P" and
        C2:"S. S  S0; S  {}; ¬ c (iti c f σ0); I S (iti c f σ0)  P"

      from foldli_transform obtain l0 where l0_props:
         "distinct l0" "S0 = set l0" "sorted_wrt R l0"  "iti c = foldli l0 c" by auto

      from I R  
      have "I {} (iti c f σ0)  
          (S. S  S0  S  {}  
               ¬ (c (iti c f σ0))  
               I S (iti c f σ0))" 
        unfolding l0_props using l0_props(1,3)
      proof (induct l0 arbitrary: σ0)
        case Nil thus ?case by simp
      next
        case (Cons x l0)
        note ind_hyp = Cons(1)
        note I_x_l0 = Cons(2)
        note step = Cons(3)
        from Cons(4) have dist_l0: "distinct l0" and x_nin_l0: "x  set l0" by simp_all
        from Cons(5) have R_l0: "yset l0. R x y" and 
                          sort_l0: "sorted_wrt R l0" by simp_all

        show ?case
        proof (cases "c σ0")
          case False
          with I_x_l0 show ?thesis
            apply (rule_tac disjI2)
            apply (rule_tac exI[where x="set (x # l0)"])
            apply (simp)
          done
        next
          case True note c_σ0 = this

          from step[of σ0 x "set (x # l0)"] I_x_l0 R_l0 c_σ0 x_nin_l0
          have step': "I (set l0) (f x σ0)"
            by (simp_all add: Ball_def)

          from ind_hyp [OF step' step dist_l0 sort_l0]
          have "I {} (foldli l0 c f (f x σ0))  
                (S. S  set l0  S  {} 
                ¬ c (foldli l0 c f (f x σ0))  I S (foldli l0 c f (f x σ0)))" 
            by (fastforce)
          thus ?thesis
            by (simp add: c_σ0 subset_iff) metis
        qed
      qed
      with C1 C2 have "P" by blast
    } note aux = this

    from assms
    show ?thesis 
      apply (rule_tac aux [of "λS σ. I S σ  (xS. yS0-S. R y x)" σ0 f])
      apply auto
    done
  qed

  text ‹Instead of removing elements one by one from the invariant, adding them is sometimes more natural.›
  lemma iteratei_rule_insert_P:
  assumes pre :
      "I {} σ0"
      "S σ x.  c σ; x  S0 - S; I S σ; S  S0; y(S0 - S) - {x}. R x y;
                 yS. R y x 
                   I (insert x S) (f x σ)"
      "σ. I S0 σ  P σ"
      "σ S.  S  S0; S  S0; 
              ¬ (c σ); I S σ; xS0-S. yS. R y x   P σ"
  shows "P (iti c f σ0)"
  proof -
    let ?I' = "λS σ. I (S0 - S) σ"

    have pre1: 
      "!!σ S.  S  S0; S  {}; ¬ (c σ); ?I' S σ;
             xS. yS0-S. R y x  P σ"
    proof -
      fix S σ
      assume AA: 
        "S  S0" "S  {}"
        "¬ (c σ)" 
        "?I' S σ" "xS. yS0-S. R y x"
      with pre(4) [of "S0 - S"]
      show "P σ" by auto
    qed

    have pre2 :"x S σ. c σ; x  S; S  S0; ?I' S σ; yS - {x}. R x y; yS0-S. R y x   ?I' (S - {x}) (f x σ)"
    proof -
      fix x S σ
      assume AA : "c σ" "x  S" "S  S0" "?I' S σ" "yS - {x}. R x y" "yS0 - S. R y x" 

      from AA(2) AA(3) have "S0 - (S - {x}) = insert x (S0 - S)" "S0 - (S0 - S) = S" by auto
      moreover 
      note pre(2) [of σ x "S0 - S"] AA
      ultimately show "?I' (S - {x}) (f x σ)"
        by auto
    qed

    show "P (iti c f σ0)" 
      apply (rule iteratei_rule_P [of ?I' σ0 c f P])
      apply (simp add: pre)
      apply (rule pre2) apply simp_all
      apply (simp add: pre(3))
      apply (simp add: pre1)
    done
  qed

  text ‹Show that iti without interruption is related to fold›
  lemma iti_fold: 
  assumes lc_f: "comp_fun_commute f"
    shows "iti (λ_. True) f σ0 = Finite_Set.fold f σ0 S0"
  proof (rule iteratei_rule_insert_P [where I = "λX σ'. σ' = Finite_Set.fold f σ0 X"])
    fix S σ x
    assume "x  S0 - S" "S  S0" and σ_eq: "σ = Finite_Set.fold f σ0 S"
    from finite_S0 S  S0 have fin_S: "finite S" by (metis finite_subset)
    from x  S0 - S have x_nin_S: "x  S" by simp
    note fold_eq = comp_fun_commute.fold_insert [OF lc_f fin_S x_nin_S]

    show "f x σ = Finite_Set.fold f σ0 (insert x S)" 
      by (simp add: fold_eq σ_eq)
  qed simp_all
end


subsection ‹Iterators over Maps›

type_synonym ('k,'v,) map_iterator = "('k×'v,) set_iterator"

text ‹Iterator over the key-value pairs of a finite map are called iterators over maps.›
abbreviation "map_iterator_genord it m R  set_iterator_genord it (map_to_set m) R"

subsection ‹Unordered Iterators›

text ‹Often one does not care about the order in which the elements are processed. 
        Therefore, the selection function can be set to not impose any further restrictings.
        This leads to considerably simpler theorems.›

definition "set_iterator it S0  set_iterator_genord it S0 (λ_ _. True)"
abbreviation "map_iterator it m  set_iterator it (map_to_set m)"

lemma set_iterator_intro :
    "set_iterator_genord it S0 R  set_iterator it S0"
unfolding set_iterator_def
apply (rule set_iterator_genord.set_iterator_weaken_R [where R = R])
apply simp_all
done

lemma set_iterator_no_cond_rule_P:
" set_iterator it S0;
   I S0 σ0;
   !!S σ x.  x  S; I S σ; S  S0   I (S - {x}) (f x σ);
   !!σ. I {} σ  P σ
   P (it (λ_. True) f σ0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_P [of it S0 "λ_ _. True" I σ0 "λ_. True" f P]
by simp 

lemma set_iterator_no_cond_rule_insert_P:
" set_iterator it S0;
   I {} σ0;
   !!S σ x.  x  S0 - S; I S σ; S  S0    I (insert x S) (f x σ);
   !!σ. I S0 σ  P σ
   P (it (λ_. True) f σ0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_insert_P [of it S0 "λ_ _. True" I σ0 "λ_. True" f P]
by simp 

lemma set_iterator_rule_P:
" set_iterator it S0;
   I S0 σ0;
   !!S σ x.  c σ; x  S; I S σ; S  S0   I (S - {x}) (f x σ);
   !!σ. I {} σ  P σ;
   !!σ S. S  S0  S  {}  ¬ c σ  I S σ  P σ
   P (it c f σ0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_P [of it S0 "λ_ _. True" I σ0 c f P]
by simp 

lemma set_iterator_rule_insert_P:
" set_iterator it S0;
   I {} σ0;
   !!S σ x.  c σ; x  S0 - S; I S σ; S  S0    I (insert x S) (f x σ);
   !!σ. I S0 σ  P σ;
   !!σ S. S  S0  S  S0  ¬ c σ  I S σ  P σ
   P (it c f σ0)"
unfolding set_iterator_def
using set_iterator_genord.iteratei_rule_insert_P [of it S0 "λ_ _. True" I σ0 c f P]
by simp  


text‹The following rules is adapted for maps. Instead of a set of key-value pairs the invariant
       now only sees the keys.›
lemma map_iterator_genord_rule_P:
  assumes "map_iterator_genord it m R"
      and I0: "I (dom m) σ0"
      and IP: "!!k v it σ.  c σ; k  it; m k = Some v; it  dom m; I it σ; 
                             k' v'. k'  it-{k}  m k' = Some v'  R (k, v) (k', v');
                             k' v'. k'  it  m k' = Some v'  R (k', v') (k, v)  
                            I (it - {k}) (f (k, v) σ)"
      and IF: "!!σ. I {} σ  P σ"
      and II: "!!σ it.  it  dom m; it  {}; ¬ c σ; I it σ;
                         k v k' v'. k  it  m k = Some v  k'  it  m k' = Some v'  
                                     R (k, v) (k', v')   P σ"
  shows "P (it c f σ0)"
proof (rule set_iterator_genord.iteratei_rule_P [of it "map_to_set m" R "λS σ. I (fst ` S) σ" σ0 c f P])
  show "map_iterator_genord it m R" by fact
next
  show "I (fst ` map_to_set m) σ0" using I0 by (simp add: map_to_set_dom[symmetric])
next
  fix σ
  assume "I (fst ` {}) σ"
  with IF show "P σ" by simp
next
  fix σ S
  assume "S  map_to_set m" "S  {}" "¬ c σ" "I (fst ` S) σ"  
         and R_prop: "xS. ymap_to_set m - S. R y x"
  let ?S' = "fst ` S"

  show "P σ"
  proof (rule II [where it = ?S'])
    from S  map_to_set m
    show "?S'  dom m"
      unfolding map_to_set_dom
      by auto
  next
    from S  {} show "?S'  {}" by auto
  next
    show "¬ (c σ)" by fact
  next
    show "I (fst ` S) σ" by fact
  next
    show "k v k' v'.
       k  fst ` S 
       m k = Some v 
       k'  fst ` S  m k' = Some v' 
       R (k, v) (k', v')" 
    proof (intro allI impI, elim conjE )
      fix k v k' v'
      assume pre_k: "k  fst ` S" "m k = Some v"
      assume pre_k': "k'  fst ` S" "m k' = Some v'"

      from S  map_to_set m pre_k' 
      have kv'_in: "(k', v')  S"
        unfolding map_to_set_def by auto

      from S  map_to_set m pre_k
      have kv_in: "(k, v)  map_to_set m - S"
        unfolding map_to_set_def 
        by (auto simp add: image_iff)

      from R_prop kv_in kv'_in
      show "R (k, v) (k',v')" by simp
    qed
  qed
next
  fix σ S kv
  assume "S  map_to_set m" "kv  S" "c σ" and I_S': "I (fst ` S) σ" and 
         R_S: "kv'S - {kv}. R kv kv'" and
         R_not_S: "kv'map_to_set m - S. R kv' kv"
  let ?S' = "fst ` S" 
  obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)

  have "I (fst ` S - {k}) (f (k, v) σ)"
  proof (rule IP)
    show "c σ" by fact
  next
    from kv  S show "k  ?S'" by (auto simp add: image_iff Bex_def)
  next
    from kv  S S  map_to_set m 
    have "kv  map_to_set m" by auto
    thus m_k_eq: "m k = Some v" unfolding map_to_set_def by simp
  next
    from S  map_to_set m
    show S'_subset: "?S'  dom m"
      unfolding map_to_set_dom
      by auto
  next
    show "I (fst ` S) σ" by fact
  next
    from S  map_to_set m kv  S
    have S_simp: "{(k', v'). k'  (fst ` S) - {k}  m k' = Some v'} = S - {kv}"
      unfolding map_to_set_def subset_iff
      apply (auto simp add: image_iff Bex_def)
      apply (metis option.inject)
    done

    from R_S[unfolded S_simp[symmetric]] R_not_S
    show "k' v'. k'  fst ` S - {k}  m k' = Some v' 
                  R (k, v) (k', v') " 
      by simp
  next
    from S  map_to_set m R_not_S
    show "k' v'. k'  fst ` S  m k' = Some v'  R (k', v') (k, v)" 
      apply (simp add: Ball_def map_to_set_def subset_iff image_iff)
      apply metis
    done
  qed

  moreover 
    from S  map_to_set m kv  S
    have "fst ` (S - {kv}) = fst ` S - {k}"
      apply (simp add: set_eq_iff image_iff Bex_def map_to_set_def subset_iff)
      apply (metis option.inject)
    done

  ultimately show "I (fst ` (S - {kv})) (f kv σ)" by simp
qed

lemma map_iterator_genord_rule_insert_P:
  assumes "map_iterator_genord it m R"
      and I0: "I {} σ0"
      and IP: "!!k v it σ.  c σ; k  dom m - it; m k = Some v; it  dom m; I it σ; 
                             k' v'. k'  (dom m - it) - {k}  m k' = Some v'  R (k, v) (k', v');
                             k' v'. k'  it  m k' = Some v'  
                               R (k', v') (k, v)  I (insert k it) (f (k, v) σ)"
      and IF: "!!σ. I (dom m) σ  P σ"
      and II: "!!σ it.  it  dom m; it  dom m; ¬ c σ; I it σ;
                         k v k' v'. k  it  m k = Some v  k'  it  m k' = Some v'  
                                     R (k, v) (k', v')   P σ"
  shows "P (it c f σ0)"
proof (rule map_iterator_genord_rule_P [of it m R "λS σ. I (dom m - S) σ"])
  show "map_iterator_genord it m R" by fact
next
  show "I (dom m - dom m) σ0" using I0 by simp
next
  fix σ
  assume "I (dom m - {}) σ"
  with IF show "P σ" by simp
next
  fix σ it
  assume assms: "it  dom m" "it  {}" "¬ c σ" "I (dom m - it) σ"
                "k v k' v'. k  it  m k = Some v  k'  it  m k' = Some v' 
                             R (k, v) (k', v')"
  from assms have "dom m - it  dom m" by auto
  with II[of "dom m - it" σ] assms
  show "P σ" 
    apply (simp add: subset_iff dom_def)
    apply (metis option.simps(2))
  done
next
  fix k v it σ
  assume assms: "c σ" "k  it" "m k = Some v" "it  dom m" "I (dom m - it) σ"
                "k' v'. k'  it - {k}  m k' = Some v'  R (k, v) (k', v')"
                "k' v'. k'  it  m k' = Some v'  R (k', v') (k, v)"

  hence "insert k (dom m - it) = (dom m - (it - {k}))" "dom m - (dom m - it) = it" by auto
  with assms IP[of σ k "dom m - it" v]
  show "I (dom m - (it - {k})) (f (k, v) σ)" by (simp_all add: subset_iff)
qed

lemma map_iterator_rule_P:
  assumes "map_iterator it m"
      and I0: "I (dom m) σ0"
      and IP: "!!k v it σ.  c σ; k  it; m k = Some v; it  dom m; I it σ   I (it - {k}) (f (k, v) σ)"
      and IF: "!!σ. I {} σ  P σ"
      and II: "!!σ it.  it  dom m; it  {}; ¬ c σ; I it σ   P σ"
  shows "P (it c f σ0)"
using assms map_iterator_genord_rule_P[of it m "λ_ _. True" I σ0 c f P]
unfolding set_iterator_def
by simp

lemma map_iterator_rule_insert_P:
  assumes "map_iterator it m"
      and I0: "I {} σ0"
      and IP: "!!k v it σ.  c σ; k  dom m - it; m k = Some v; it  dom m; I it σ   I (insert k it) (f (k, v) σ)"
      and IF: "!!σ. I (dom m) σ  P σ"
      and II: "!!σ it.  it  dom m; it  dom m; ¬ c σ; I it σ   P σ"
  shows "P (it c f σ0)"
using assms map_iterator_genord_rule_insert_P[of it m "λ_ _. True" I σ0 c f P]
unfolding set_iterator_def
by simp

lemma map_iterator_no_cond_rule_P:
  assumes "map_iterator it m"
      and I0: "I (dom m) σ0"
      and IP: "!!k v it σ.  k  it; m k = Some v; it  dom m; I it σ   I (it - {k}) (f (k, v) σ)"
      and IF: "!!σ. I {} σ  P σ"
  shows "P (it (λ_. True) f σ0)"
using assms map_iterator_genord_rule_P[of it m "λ_ _. True" I σ0 "λ_. True" f P]
unfolding set_iterator_def
by simp

lemma map_iterator_no_cond_rule_insert_P:
  assumes "map_iterator it m"
      and I0: "I {} σ0"
      and IP: "!!k v it σ.  k  dom m - it; m k = Some v; it  dom m; I it σ   I (insert k it) (f (k, v) σ)"
      and IF: "!!σ. I (dom m) σ  P σ"
  shows "P (it (λ_. True) f σ0)"
using assms map_iterator_genord_rule_insert_P[of it m "λ_ _. True" I σ0 "λ_. True" f P]
unfolding set_iterator_def
by simp


subsection ‹Ordered Iterators›

text ‹Selecting according to a linear order is another case that is interesting. 
 Ordered iterators over maps, i.\,e.\ iterators over key-value pairs,
 use an order on the keys.›

context linorder begin
  definition "set_iterator_linord it S0 
     set_iterator_genord it S0 (≤)"
  definition "set_iterator_rev_linord it S0 
     set_iterator_genord it S0 (≥)"
  definition "set_iterator_map_linord it S0  
     set_iterator_genord it S0 (λ(k,_) (k',_). kk')"
  definition "set_iterator_map_rev_linord it S0  
     set_iterator_genord it S0 (λ(k,_) (k',_). kk')"
  abbreviation "map_iterator_linord it m  
    set_iterator_map_linord it (map_to_set m)"
  abbreviation "map_iterator_rev_linord it m  
    set_iterator_map_rev_linord it (map_to_set m)"

  lemma set_iterator_linord_rule_P:
  " set_iterator_linord it S0;
     I S0 σ0;
     !!S σ x.  c σ; x  S; I S σ; S  S0; x'. x'  S0-S  x'  x; x'. x'  S  x  x'  I (S - {x}) (f x σ);
     !!σ. I {} σ  P σ;
     !!σ S. S  S0  S  {}  (x x'. x  S; x'  S0-S  x'  x)  ¬ c σ  I S σ  P σ
     P (it c f σ0)"
  unfolding set_iterator_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "(≤)" I σ0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_linord_rule_insert_P:
  " set_iterator_linord it S0;
     I {} σ0;
     !!S σ x.  c σ; x  S0 - S; I S σ; S  S0; x'. x'  S  x'  x; x'. x'  S0 - S  x  x'   I (insert x S) (f x σ);
     !!σ. I S0 σ  P σ;
     !!σ S. S  S0  S  S0  (x x'. x  S0-S; x'  S  x'  x)  ¬ c σ  I S σ  P σ
     P (it c f σ0)"
  unfolding set_iterator_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "(≤)" I σ0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_rev_linord_rule_P:
  " set_iterator_rev_linord it S0;
     I S0 σ0;
     !!S σ x.  c σ; x  S; I S σ; S  S0; x'. x'  S0-S  x  x'; x'. x'  S  x'  x  I (S - {x}) (f x σ);
     !!σ. I {} σ  P σ;
     !!σ S. S  S0  S  {}  (x x'. x  S; x'  S0-S  x  x')  ¬ c σ  I S σ  P σ
     P (it c f σ0)"
  unfolding set_iterator_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "(≥)" I σ0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done

  lemma set_iterator_rev_linord_rule_insert_P:
  " set_iterator_rev_linord it S0;
     I {} σ0;
     !!S σ x.  c σ; x  S0 - S; I S σ; S  S0; x'. x'  S  x  x'; x'. x'  S0 - S  x'  x   I (insert x S) (f x σ);
     !!σ. I S0 σ  P σ;
     !!σ S. S  S0  S  S0   (x x'. x  S0-S; x'  S  x  x')  ¬ c σ  I S σ  P σ
     P (it c f σ0)"
  unfolding set_iterator_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "(≥)" I σ0 c f P])
  apply (simp_all add: Ball_def)
  apply (metis order_refl)
  done


  lemma set_iterator_map_linord_rule_P:
  " set_iterator_map_linord it S0;
     I S0 σ0;
     !!S σ k v.  c σ; (k, v)  S; I S σ; S  S0; k' v'. (k', v')  S0-S  k'  k;
                  k' v'. (k', v')  S  k  k'  I (S - {(k,v)}) (f (k,v) σ);
     !!σ. I {} σ  P σ;
     !!σ S. S  S0  S  {}  (k v k' v'. (k, v)  S0-S; (k', v')  S  k  k') 
         ¬ c σ  I S σ  P σ
     P (it c f σ0)"
  unfolding set_iterator_map_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P 
    [of it S0 "(λ(k,_) (k',_). k  k')" I σ0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma set_iterator_map_linord_rule_insert_P:
  " set_iterator_map_linord it S0;
     I {} σ0;
     !!S σ k v.  c σ; (k, v)  S0 - S; I S σ; S  S0; k' v'. (k', v')  S  k'  k;
                  k' v'. (k',v')  S0 - S  k  k'   I (insert (k,v) S) (f (k,v) σ);
     !!σ. I S0 σ  P σ;
     !!σ S. S  S0  S  S0  (k v k' v'. (k, v)  S; (k', v')  S0-S  k  k') 
            ¬ c σ  I S σ  P σ
     P (it c f σ0)"
  unfolding set_iterator_map_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P 
    [of it S0 "(λ(k,_) (k',_). k  k')" I σ0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma set_iterator_map_rev_linord_rule_P:
  " set_iterator_map_rev_linord it S0;
     I S0 σ0;
     !!S σ k v.  c σ; (k, v)  S; I S σ; S  S0; k' v'. (k', v')  S0-S  k  k';
                  k' v'. (k', v')  S  k'  k  I (S - {(k,v)}) (f (k,v) σ);
     !!σ. I {} σ  P σ;
     !!σ S. S  S0  S  {}  (k v k' v'. (k, v)  S0-S; (k', v')  S  k'  k)  
            ¬ c σ  I S σ  P σ
     P (it c f σ0)"
  unfolding set_iterator_map_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_P 
    [of it S0 "(λ(k,_) (k',_). k  k')" I σ0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done

  lemma set_iterator_map_rev_linord_rule_insert_P:
  " set_iterator_map_rev_linord it S0;
     I {} σ0;
     !!S σ k v.  c σ; (k, v)  S0 - S; I S σ; S  S0; k' v'. (k', v')  S  k  k';
                 k' v'. (k',v')  S0 - S  k'  k   I (insert (k,v) S) (f (k,v) σ);
     !!σ. I S0 σ  P σ;
     !!σ S. S  S0  S  S0  (k v k' v'. (k, v)  S; (k', v')  S0-S  k'  k)  
            ¬ c σ  I S σ  P σ
     P (it c f σ0)"
  unfolding set_iterator_map_rev_linord_def
  apply (rule set_iterator_genord.iteratei_rule_insert_P 
    [of it S0 "(λ(k,_) (k',_). k  k')" I σ0 c f P])
  apply simp_all
  apply (auto simp add: Ball_def)
  apply (metis order_refl)
  apply metis
  done


  lemma map_iterator_linord_rule_P:
    assumes "map_iterator_linord it m"
        and I0: "I (dom m) σ0"
        and IP: "!!k v it σ.  c σ; k  it; m k = Some v; it  dom m; I it σ;
                 k'. k'  it  k  k'; 
                 k'. k'  (dom m)-it  k'  k  I (it - {k}) (f (k, v) σ)"
        and IF: "!!σ. I {} σ  P σ"
        and II: "!!σ it.  it  dom m; it  {}; ¬ c σ; I it σ;
                  k k'. k  (dom m)-it; k'  it  k  k'  P σ"
    shows "P (it c f σ0)"
  using assms
  unfolding set_iterator_map_linord_def
  by (rule map_iterator_genord_rule_P) auto

  lemma map_iterator_linord_rule_insert_P:
    assumes "map_iterator_linord it m"
        and I0: "I {} σ0"
        and IP: "!!k v it σ.  c σ; k  dom m - it; m k = Some v; it  dom m; I it σ;
                 k'. k'  (dom m - it)  k  k'; 
                 k'. k'  it  k'  k   I (insert k it) (f (k, v) σ)"
        and IF: "!!σ. I (dom m) σ  P σ"
        and II: "!!σ it.  it  dom m; it  dom m; ¬ c σ; I it σ;
                  k k'. k  it; k'  (dom m)-it  k  k'  P σ"
    shows "P (it c f σ0)"
  using assms
  unfolding set_iterator_map_linord_def
  by (rule map_iterator_genord_rule_insert_P) auto

  lemma map_iterator_rev_linord_rule_P:
    assumes "map_iterator_rev_linord it m"
        and I0: "I (dom m) σ0"
        and IP: "!!k v it σ.  c σ; k  it; m k = Some v; it  dom m; I it σ;
                 k'. k'  it  k'  k; 
                 k'. k'  (dom m)-it  k  k'  I (it - {k}) (f (k, v) σ)"
        and IF: "!!σ. I {} σ  P σ"
        and II: "!!σ it.  it  dom m; it  {}; ¬ c σ; I it σ;
                  k k'. k  (dom m)-it; k'  it  k'  k  P σ"
    shows "P (it c f σ0)"
  using assms
  unfolding set_iterator_map_rev_linord_def
  by (rule map_iterator_genord_rule_P) auto

  lemma map_iterator_rev_linord_rule_insert_P:
    assumes "map_iterator_rev_linord it m"
        and I0: "I {} σ0"
        and IP: "!!k v it σ.  c σ; k  dom m - it; m k = Some v; it  dom m; I it σ;
                 k'. k'  (dom m - it)  k'  k; 
                 k'. k'  it  k  k'  I (insert k it) (f (k, v) σ)"
        and IF: "!!σ. I (dom m) σ  P σ"
        and II: "!!σ it.  it  dom m; it  dom m; ¬ c σ; I it σ;
                  k k'. k  it; k'  (dom m)-it  k'  k  P σ"
    shows "P (it c f σ0)"
  using assms
  unfolding set_iterator_map_rev_linord_def
  by (rule map_iterator_genord_rule_insert_P) auto
end

subsection ‹Conversions to foldli›

lemma set_iterator_genord_foldli_conv :
  "set_iterator_genord iti S R 
   (l0. distinct l0  S = set l0  sorted_wrt R l0  iti = foldli l0)"
unfolding set_iterator_genord_def by simp

lemma set_iterator_genord_I [intro] :
  "distinct l0; S = set l0; sorted_wrt R l0; iti = foldli l0 
   set_iterator_genord iti S R" unfolding set_iterator_genord_foldli_conv
   by blast

lemma set_iterator_foldli_conv :
  "set_iterator iti S 
   (l0. distinct l0  S = set l0  iti = foldli l0)"
unfolding set_iterator_def set_iterator_genord_def by simp

lemma set_iterator_I [intro] :
  "distinct l0; S = set l0; iti = foldli l0 
   set_iterator iti S" 
   unfolding set_iterator_foldli_conv
   by blast

context linorder begin
  lemma set_iterator_linord_foldli_conv :
    "set_iterator_linord iti S 
     (l0. distinct l0  S = set l0  sorted l0  iti = foldli l0)"
  unfolding set_iterator_linord_def set_iterator_genord_def by (simp add: sorted_sorted_wrt)

  lemma set_iterator_linord_I [intro] :
    "distinct l0; S = set l0; sorted l0; iti = foldli l0 
     set_iterator_linord iti S" 
     unfolding set_iterator_linord_foldli_conv
     by blast

  lemma set_iterator_rev_linord_foldli_conv :
    "set_iterator_rev_linord iti S 
     (l0. distinct l0  S = set l0  sorted (rev l0)  iti = foldli l0)"
  unfolding set_iterator_rev_linord_def set_iterator_genord_def by simp

  lemma set_iterator_rev_linord_I [intro] :
    "distinct l0; S = set l0; sorted (rev l0); iti = foldli l0 
     set_iterator_rev_linord iti S" 
     unfolding set_iterator_rev_linord_foldli_conv
     by blast
end


lemma map_iterator_genord_foldli_conv :
  "map_iterator_genord iti m R 
   ((l0::('k × 'v) list). distinct (map fst l0)  m = map_of l0  sorted_wrt R l0  iti = foldli l0)"
proof -
  { fix l0 :: "('k × 'v) list"
    assume dist: "distinct l0"
    have "(map_to_set m = set l0) 
          (distinct (map fst l0) 
           m = map_of l0)"
    proof (cases "distinct (map fst l0)")
      case True thus ?thesis by (metis map_of_map_to_set)
    next
      case False note not_dist_fst = this

      with dist have "~(inj_on fst (set l0))" by (simp add: distinct_map)
      hence "set l0  map_to_set m"
        by (rule_tac notI) (simp add: map_to_set_def inj_on_def)
      with not_dist_fst show ?thesis by simp
    qed
  } 
  thus ?thesis
    unfolding set_iterator_genord_def distinct_map
    by metis
qed

lemma map_iterator_genord_I [intro] :
  "distinct (map fst l0); m = map_of l0; sorted_wrt R l0; iti = foldli l0 
   map_iterator_genord iti m R" 
   unfolding map_iterator_genord_foldli_conv
   by blast

lemma map_iterator_foldli_conv :
  "map_iterator iti m 
   (l0. distinct (map fst l0)  m = map_of l0  iti = foldli l0)"
unfolding set_iterator_def map_iterator_genord_foldli_conv 
by simp

lemma map_iterator_I [intro] :
  "distinct (map fst l0); m = map_of l0; iti = foldli l0 
   map_iterator iti m" 
   unfolding map_iterator_foldli_conv
   by blast

context linorder begin

  lemma sorted_wrt_keys_map_fst:
    "sorted_wrt (λ(k,_) (k',_). R k k') l = sorted_wrt R (map fst l)"
    by (induct l) auto

  lemma map_iterator_linord_foldli_conv :
    "map_iterator_linord iti m 
     (l0. distinct (map fst l0)  m = map_of l0  sorted (map fst l0)  iti = foldli l0)"
  unfolding set_iterator_map_linord_def map_iterator_genord_foldli_conv
  by (simp add: sorted_wrt_keys_map_fst sorted_sorted_wrt)

  lemma map_iterator_linord_I [intro] :
    "distinct (map fst l0); m = map_of l0; sorted (map fst l0); iti = foldli l0 
     map_iterator_linord iti m" 
     unfolding map_iterator_linord_foldli_conv
     by blast

  lemma map_iterator_rev_linord_foldli_conv :
    "map_iterator_rev_linord iti m 
     (l0. distinct (map fst l0)  m = map_of l0  sorted (rev (map fst l0))  iti = foldli l0)"
  unfolding set_iterator_map_rev_linord_def map_iterator_genord_foldli_conv 
  by (simp add: sorted_wrt_keys_map_fst)

  lemma map_iterator_rev_linord_I [intro] :
    "distinct (map fst l0); m = map_of l0; sorted (rev (map fst l0)); iti = foldli l0 
     map_iterator_rev_linord iti m" 
     unfolding map_iterator_rev_linord_foldli_conv
     by blast

end

end

Theory SetIteratorOperations

(*  Title:       Operations on Iterators over Finite Sets
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section ‹Operations on Set Iterators›
theory SetIteratorOperations
imports Main SetIterator
begin

text‹Many operations on sets can be lifted to iterators over sets. This theory tries to introduce
the most useful such operations.›

subsection ‹Empty set›

text ‹Iterators over empty sets and singleton sets are very easy to define.›
definition set_iterator_emp :: "('a,) set_iterator" where
  "set_iterator_emp c f σ0 = σ0"

lemma set_iterator_emp_foldli_conv :
  "set_iterator_emp = foldli []"
by (simp add: fun_eq_iff set_iterator_emp_def)

lemma set_iterator_genord_emp_correct :
  "set_iterator_genord set_iterator_emp {} R"
apply (rule set_iterator_genord.intro)
apply (rule exI[where x="[]"])
apply (simp add: set_iterator_emp_foldli_conv)
done

lemma set_iterator_emp_correct :
  "set_iterator set_iterator_emp {}"
using set_iterator_intro [OF set_iterator_genord_emp_correct] .

lemma (in linorder) set_iterator_linord_emp_correct :
  "set_iterator_linord set_iterator_emp {}"
unfolding set_iterator_linord_def
by (fact set_iterator_genord_emp_correct) 

lemma (in linorder) set_iterator_rev_linord_emp_correct :
  "set_iterator_rev_linord set_iterator_emp {}"
unfolding set_iterator_rev_linord_def
by (fact set_iterator_genord_emp_correct) 

lemma (in linorder) map_iterator_linord_emp_correct :
  "map_iterator_linord set_iterator_emp Map.empty"
  "set_iterator_map_linord set_iterator_emp {}"
unfolding set_iterator_map_linord_def
by (simp_all add: set_iterator_genord_emp_correct map_to_set_def) 

lemma (in linorder) map_iterator_rev_linord_emp_correct :
  "map_iterator_rev_linord set_iterator_emp Map.empty"
  "set_iterator_map_rev_linord set_iterator_emp {}"
unfolding set_iterator_map_rev_linord_def
by (simp_all add: set_iterator_genord_emp_correct map_to_set_def) 


subsection‹Singleton Sets›

definition set_iterator_sng :: "'a  ('a,) set_iterator" where
  "set_iterator_sng x c f σ0 = (if c σ0 then f x σ0 else σ0)"

lemma set_iterator_sng_foldli_conv :
  "set_iterator_sng x = foldli [x]"
by (simp add: fun_eq_iff set_iterator_sng_def)

lemma set_iterator_genord_sng_correct :
  "set_iterator_genord (set_iterator_sng (x::'a)) {x} R"
apply (rule set_iterator_genord.intro)
apply (rule exI[where x="[x]"])
apply (simp add: set_iterator_sng_foldli_conv)
done

lemma set_iterator_sng_correct :
  "set_iterator (set_iterator_sng x) {x}"
unfolding set_iterator_def
by (rule set_iterator_genord_sng_correct)

lemma (in linorder) set_iterator_linord_sng_correct :
  "set_iterator_linord (set_iterator_sng x) {x}"
unfolding set_iterator_linord_def
by (simp add: set_iterator_genord_sng_correct) 

lemma (in linorder) set_iterator_rev_linord_sng_correct :
  "set_iterator_rev_linord (set_iterator_sng x) {x}"
unfolding set_iterator_rev_linord_def
by (simp add: set_iterator_genord_sng_correct) 

lemma (in linorder) map_iterator_linord_sng_correct :
  "map_iterator_linord (set_iterator_sng (k,v)) (Map.empty (k  v))"
unfolding set_iterator_map_linord_def
by (simp add: set_iterator_genord_sng_correct) 

lemma (in linorder) map_iterator_rev_linord_sng_correct :
  "map_iterator_rev_linord (set_iterator_sng (k,v)) (Map.empty (k  v))"
unfolding set_iterator_map_rev_linord_def
by (simp add: set_iterator_genord_sng_correct) 


subsection ‹Union›

text ‹Iterators over disjoint sets can be combined by first iterating over one and then the
other set. The result is an iterator over the union of the original sets.›

definition set_iterator_union ::
    "('a,) set_iterator  ('a, ) set_iterator  ('a,) set_iterator" where
  "set_iterator_union it_a it_b  λc f σ0. (it_b c f (it_a c f σ0))"

lemma set_iterator_union_foldli_conv :
  "set_iterator_union (foldli as) (foldli bs) = foldli (as @ bs)"
by (simp add: fun_eq_iff set_iterator_union_def foldli_append)

lemma set_iterator_genord_union_correct :
  fixes it_a :: "('a,) set_iterator"
  fixes it_b :: "('a,) set_iterator"
  fixes R S_a S_b
  assumes it_a: "set_iterator_genord it_a S_a R"
  assumes it_b: "set_iterator_genord it_b S_b R"
  assumes dist_Sab: "S_a  S_b = {}"
  assumes R_OK: "a b. a  S_a; b  S_b  R a b"
  shows "set_iterator_genord (set_iterator_union it_a it_b) (S_a  S_b) R"
proof -
  from it_a obtain as where 
    dist_as: "distinct as" and S_a_eq: "S_a = set as" and 
    sorted_as: "sorted_wrt R as" and it_a_eq: "it_a = foldli as"
  unfolding set_iterator_genord_foldli_conv by blast

  from it_b obtain bs where 
    dist_bs: "distinct bs" and S_b_eq: "S_b = set bs" and 
    sorted_bs: "sorted_wrt R bs" and it_b_eq: "it_b = foldli bs"
  unfolding set_iterator_genord_foldli_conv by blast

  show ?thesis
  proof (rule set_iterator_genord_I [of "as @ bs"])
    from dist_Sab S_a_eq S_b_eq dist_as dist_bs
    show "distinct (as @ bs)" by simp
  next
    from S_a_eq S_b_eq 
    show "S_a  S_b = set (as @ bs)" by simp
  next
    from sorted_as sorted_bs R_OK S_a_eq S_b_eq
    show "sorted_wrt R (as @ bs)"
      by (simp add: sorted_wrt_append Ball_def)
  next
    show "set_iterator_union it_a it_b = (foldli (as @ bs))"
      unfolding it_a_eq it_b_eq set_iterator_union_foldli_conv by simp
  qed
qed

lemma set_iterator_union_emp [simp] :
  "set_iterator_union (set_iterator_emp) it = it"
  "set_iterator_union it (set_iterator_emp) = it"
unfolding set_iterator_emp_def set_iterator_union_def
by simp_all

lemma set_iterator_union_correct :
  assumes it_a: "set_iterator it_a S_a"
  assumes it_b: "set_iterator it_b S_b"
  assumes dist_Sab: "S_a  S_b = {}"
  shows "set_iterator (set_iterator_union it_a it_b) (S_a  S_b)"
proof -
  note res' = set_iterator_genord_union_correct [OF it_a[unfolded set_iterator_def] 
                                                    it_b[unfolded set_iterator_def] dist_Sab]
  from set_iterator_intro [OF res']
  show ?thesis by simp
qed

lemma (in linorder) set_iterator_linord_union_correct :
  assumes it_a: "set_iterator_linord it_a S_a"
  assumes it_b: "set_iterator_linord it_b S_b"
  assumes ord_Sab: "a b. a  S_a; b  S_b  a < b"
  shows "set_iterator_linord (set_iterator_union it_a it_b) (S_a  S_b)"
unfolding set_iterator_linord_def
apply (rule_tac set_iterator_genord_union_correct[
   OF it_a[unfolded set_iterator_linord_def] it_b[unfolded set_iterator_linord_def]])
apply (insert ord_Sab)
apply auto
apply (metis less_le_not_le ord_Sab)
done

lemma (in linorder) set_iterator_rev_linord_union_correct :
  assumes it_a: "set_iterator_rev_linord it_a S_a"
  assumes it_b: "set_iterator_rev_linord it_b S_b"
  assumes ord_Sab: "a b. a  S_a; b  S_b  a > b"
  shows "set_iterator_rev_linord (set_iterator_union it_a it_b) (S_a  S_b)"
unfolding set_iterator_rev_linord_def
apply (rule_tac set_iterator_genord_union_correct[
   OF it_a[unfolded set_iterator_rev_linord_def] it_b[unfolded set_iterator_rev_linord_def]])
apply (insert ord_Sab)
apply auto
apply (metis less_le_not_le ord_Sab)
done

lemma (in linorder) map_iterator_linord_union_correct :
  assumes it_a: "set_iterator_map_linord it_a S_a"
  assumes it_b: "set_iterator_map_linord it_b S_b"
  assumes ord_Sab: "kv kv'. kv  S_a; kv'  S_b  fst kv < fst kv'"
  shows "set_iterator_map_linord (set_iterator_union it_a it_b) (S_a  S_b)"
  unfolding set_iterator_map_linord_def
  apply (rule set_iterator_genord_union_correct [OF 
    it_a[unfolded set_iterator_map_linord_def] 
    it_b[unfolded set_iterator_map_linord_def]])
  apply (insert ord_Sab)
  apply auto
  apply (metis less_le_not_le)
done

lemma (in linorder) map_iterator_rev_linord_union_correct :
  assumes it_a: "set_iterator_map_rev_linord it_a S_a"
  assumes it_b: "set_iterator_map_rev_linord it_b S_b"
  assumes ord_Sab: "kv kv'. kv  S_a; kv'  S_b  fst kv > fst kv'"
  shows "set_iterator_map_rev_linord (set_iterator_union it_a it_b) (S_a  S_b)"
  unfolding set_iterator_map_rev_linord_def
  apply (rule set_iterator_genord_union_correct [OF 
    it_a[unfolded set_iterator_map_rev_linord_def] 
    it_b[unfolded set_iterator_map_rev_linord_def]])
  apply (insert ord_Sab)
  apply auto
  apply (metis less_le_not_le)
done


subsection ‹Product›

definition set_iterator_product :: 
    "('a,) set_iterator  ('a  ('b,) set_iterator)  ('a × 'b ,) set_iterator" where
  "set_iterator_product it_a it_b  λc f σ0.
    it_a c (
      λa σ. it_b a c (λb σ. f (a,b) σ) σ
    ) σ0"


lemma set_iterator_product_foldli_conv: 
  "set_iterator_product (foldli as) (λa. foldli (bs a)) =
   foldli (concat (map (λa. map (λb. (a, b)) (bs a)) as))"
apply (induct as)
  apply (simp add: set_iterator_product_def)
apply (simp add: set_iterator_product_def foldli_append foldli_map o_def fun_eq_iff)
done

lemma set_iterator_product_it_b_cong: 
assumes it_a_OK: "set_iterator it_a S_a"
    and it_b_b': "a. a  S_a  it_b a = it_b' a"
shows "set_iterator_product it_a it_b =
       set_iterator_product it_a it_b'"
proof -
  from it_a_OK obtain as where 
    dist_as: "distinct as" and S_a_eq: "S_a = set as" and 
    it_a_eq: "it_a = foldli as"
  unfolding set_iterator_foldli_conv by blast
  
  from it_b_b'[unfolded S_a_eq]
  show ?thesis unfolding it_a_eq
    by (induct as) 
       (simp_all add: set_iterator_product_def it_b_b' fun_eq_iff)
qed

definition set_iterator_product_order ::
  "('a  'a  bool)  ('a  'b  'b  bool) 
   ('a × 'b)  ('a × 'b)  bool" where
  "set_iterator_product_order R_a R_b ab ab' 
   (if (fst ab = fst ab') then R_b (fst ab) (snd ab) (snd ab') else
                               R_a (fst ab) (fst ab'))"

lemma set_iterator_genord_product_correct :
  fixes it_a :: "('a,) set_iterator"
  fixes it_b :: "'a  ('b,) set_iterator" 
  assumes it_a: "set_iterator_genord it_a S_a R_a"
  assumes it_b: "a. a  S_a  set_iterator_genord (it_b a) (S_b a) (R_b a)"
  shows "set_iterator_genord (set_iterator_product it_a it_b) (Sigma S_a S_b) 
             (set_iterator_product_order R_a R_b)"
proof -
  from it_a obtain as where 
    dist_as: "distinct as" and S_a_eq: "S_a = set as" and 
    sorted_as: "sorted_wrt R_a as" and it_a_eq: "it_a = foldli as"
  unfolding set_iterator_genord_foldli_conv by blast

  from it_b obtain bs where 
    dist_bs: "a. a  set as  distinct (bs a)" and S_b_eq: "a. a  set as   S_b a = set (bs a)" and 
    sorted_bs: "a. a  set as  sorted_wrt (R_b a) (bs a)" and 
    it_b_eq: "a. a  set as  it_b a = foldli (bs a)"
  unfolding set_iterator_genord_foldli_conv by (metis S_a_eq)

  let ?abs = "concat (map (λa. map (λb. (a, b)) (bs a)) as)"

  show ?thesis
  proof (rule set_iterator_genord_I[of ?abs])
    from set_iterator_product_it_b_cong[of it_a S_a it_b, 
       OF set_iterator_intro[OF it_a] it_b_eq] it_a_eq S_a_eq
    have "set_iterator_product it_a it_b =
          set_iterator_product (foldli as) (λa. foldli (bs a))" by simp
    thus "set_iterator_product it_a it_b = foldli ?abs"
      by (simp add: set_iterator_product_foldli_conv)
  next
    show "distinct ?abs"
    using dist_as dist_bs[unfolded S_a_eq]
    by (induct as) 
       (simp_all add: distinct_map inj_on_def dist_bs set_eq_iff image_iff)
  next
    show "Sigma S_a S_b = set ?abs" 
      unfolding S_a_eq using S_b_eq
      by (induct as) auto  
  next
    from sorted_as sorted_bs dist_as     
    show "sorted_wrt
           (set_iterator_product_order R_a R_b)
           (concat (map (λa. map (Pair a) (bs a)) as))"
    proof (induct as rule: list.induct)
      case Nil thus ?case by simp
    next
      case (Cons a as)
      from Cons(2) have R_a_as: "a'. a'  set as  R_a a a'" and
                        sorted_as: "sorted_wrt R_a as" by simp_all
      from Cons(3) have sorted_bs_a: "sorted_wrt (R_b a) (bs a)" 
                    and sorted_bs_as: "a. a  set as  sorted_wrt (R_b a) (bs a)" by simp_all
      from Cons(4) have dist_as: "distinct as" and a_nin_as: "a  set as" by simp_all
      note ind_hyp = Cons(1)[OF sorted_as sorted_bs_as dist_as]
      
      define bs_a where "bs_a = bs a"
      from sorted_bs_a
      have sorted_prod_a : "sorted_wrt (set_iterator_product_order R_a R_b) (map (Pair a) (bs a))"
        unfolding bs_a_def[symmetric]
        apply (induct bs_a rule: list.induct) 
        apply (simp_all add: set_iterator_product_order_def Ball_def image_iff)
      done

      show ?case
        apply (simp add: sorted_wrt_append ind_hyp sorted_prod_a)
        apply (simp add: set_iterator_product_order_def R_a_as a_nin_as)
      done
    qed
  qed
qed

lemma set_iterator_product_correct :
  assumes it_a: "set_iterator it_a S_a"
  assumes it_b: "a. a  S_a  set_iterator (it_b a) (S_b a)"
  shows "set_iterator (set_iterator_product it_a it_b) (Sigma S_a S_b)"
proof -
  note res' = set_iterator_genord_product_correct [OF it_a[unfolded set_iterator_def], 
     of it_b S_b "λ_ _ _. True", OF it_b[unfolded set_iterator_def]]
  note res = set_iterator_intro [OF res']
  thus ?thesis by simp
qed


subsection ‹Filter and Image›

text ‹Filtering and applying an injective function on iterators is easily defineable as well.
  In contrast to sets the function really has to be injective, because an iterator guarentees to
  visit each element only once.›

definition set_iterator_image_filter ::
    "('a  'b option)  ('a,) set_iterator  ('b,) set_iterator" where
  "set_iterator_image_filter g it  λc f σ0. (it c
     (λx σ. (case (g x) of Some x'  f x' σ | None  σ)) σ0)"

lemma set_iterator_image_filter_foldli_conv :
  "set_iterator_image_filter g (foldli xs) =
   foldli (List.map_filter g xs)"
by (induct xs) (auto simp add: List.map_filter_def set_iterator_image_filter_def fun_eq_iff)  

lemma set_iterator_genord_image_filter_correct :
  fixes it :: "('a,) set_iterator"
  fixes g :: "'a  'b option"
  assumes it_OK: "set_iterator_genord it S R"
  assumes g_inj_on: "inj_on g (S  dom g)"
  assumes R'_prop: "x y x' y'. x  S; g x = Some x'; y  S; g y = Some y'; R x y  R' x' y'"
  shows "set_iterator_genord (set_iterator_image_filter g it) {y. x. x  S  g x = Some y} R'"
proof -
  from it_OK obtain xs where 
    dist_xs: "distinct xs" and S_eq: "S = set xs" and 
    sorted_xs: "sorted_wrt R xs" and it_eq: "it = foldli xs"
  unfolding set_iterator_genord_foldli_conv by blast

  show ?thesis
  proof (rule set_iterator_genord_I [of "List.map_filter g xs"])
    show "set_iterator_image_filter g it =
          foldli (List.map_filter g xs)"
      unfolding it_eq  set_iterator_image_filter_foldli_conv by simp
  next
    from dist_xs g_inj_on[unfolded S_eq]
    show "distinct (List.map_filter g xs)"
      apply (induct xs)
      apply (simp add: List.map_filter_simps) 
      apply (simp add: List.map_filter_def image_iff inj_on_def Ball_def dom_def)
      apply (metis not_Some_eq option.sel)
    done
  next
    show "{y. x. x  S  g x = Some y} =
          set (List.map_filter g xs)"
      unfolding S_eq set_map_filter by simp
  next
    from sorted_xs R'_prop[unfolded S_eq]
    show "sorted_wrt R' (List.map_filter g xs)"
    proof (induct xs rule: list.induct)
      case Nil thus ?case by (simp add: List.map_filter_simps) 
    next
      case (Cons x xs)
      note sort_x_xs = Cons(2)
      note R'_x_xs = Cons(3)

      from Cons have ind_hyp: "sorted_wrt R' (List.map_filter g xs)" by auto

      show ?case
        apply (cases "g x")  
        apply (simp add: List.map_filter_simps ind_hyp)
        apply (simp add: List.map_filter_simps set_map_filter Ball_def ind_hyp)
        apply (insert R'_x_xs[of x] sort_x_xs)
        apply (simp add: Ball_def)
        apply metis
      done
    qed
  qed
qed


lemma set_iterator_image_filter_correct :
  fixes it :: "('a,) set_iterator"
  fixes g :: "'a  'b option"
  assumes it_OK: "set_iterator it S"
  assumes g_inj_on: "inj_on g (S  dom g)"
  shows "set_iterator (set_iterator_image_filter g it) {y. x. x  S  g x = Some y}"
proof -
  note res' = set_iterator_genord_image_filter_correct [OF it_OK[unfolded set_iterator_def], 
     of g "λ_ _. True"]
  note res = set_iterator_intro [OF res']
  with g_inj_on show ?thesis by simp 
qed


text ‹Special definitions for only filtering or only appling a function are handy.›
definition set_iterator_filter ::
    "('a  bool)  ('a,) set_iterator  ('a,) set_iterator" where
  "set_iterator_filter P  set_iterator_image_filter (λx. if P x then Some x else None)"

lemma set_iterator_filter_foldli_conv :
  "set_iterator_filter P (foldli xs) = foldli (filter P xs)"
  apply (simp add: set_iterator_filter_def set_iterator_image_filter_foldli_conv)
  apply (rule cong) apply simp
  apply (induct xs)
  apply (simp_all add: List.map_filter_def)
done

lemma set_iterator_filter_alt_def [code] : 
  "set_iterator_filter P it = (λc f. it c (λ(x::'a) (σ::'b). if P x then f x σ else σ))"
proof -
  have "f. (λ(x::'a) (σ::'b).
             case if P x then Some x else None of None  σ
             | Some x'  f x' σ) =
            (λx σ. if P x then f x σ else σ)"
     by auto
  thus ?thesis 
    unfolding set_iterator_filter_def
              set_iterator_image_filter_def[abs_def]
    by simp
qed

lemma set_iterator_genord_filter_correct :
  fixes it :: "('a,) set_iterator"
  assumes it_OK: "set_iterator_genord it S R"
  shows "set_iterator_genord (set_iterator_filter P it) {x. x  S  P x} R"
proof -
  let ?g = "λx. if P x then Some x else None"
  have in_dom_g: "x. x  dom ?g  P x" unfolding dom_def by auto

  from set_iterator_genord_image_filter_correct [OF it_OK, of ?g R, folded set_iterator_filter_def]
  show ?thesis
    by (simp add: if_split_eq1 inj_on_def Ball_def in_dom_g)
qed

lemma set_iterator_filter_correct :
  assumes it_OK: "set_iterator it S"
  shows "set_iterator (set_iterator_filter P it) {x. x  S  P x}"
proof -
  note res' = set_iterator_genord_filter_correct [OF it_OK[unfolded set_iterator_def], 
    of P]
  note res = set_iterator_intro [OF res']
  thus ?thesis by simp
qed

lemma (in linorder) set_iterator_linord_filter_correct :
  assumes it_OK: "set_iterator_linord it S"
  shows "set_iterator_linord (set_iterator_filter P it) {x. x  S  P x}"
using assms
unfolding set_iterator_linord_def
by (rule set_iterator_genord_filter_correct)

lemma (in linorder) set_iterator_rev_linord_filter_correct :
  assumes it_OK: "set_iterator_rev_linord it S"
  shows "set_iterator_rev_linord (set_iterator_filter P it) {x. x  S  P x}"
using assms
unfolding set_iterator_rev_linord_def
by (rule set_iterator_genord_filter_correct)

definition set_iterator_image ::
    "('a  'b)  ('a,) set_iterator  ('b,) set_iterator" where
  "set_iterator_image g  set_iterator_image_filter (λx. Some (g x))"

lemma set_iterator_image_foldli_conv :
  "set_iterator_image g (foldli xs) = foldli (map g xs)"
  apply (simp add: set_iterator_image_def set_iterator_image_filter_foldli_conv)
  apply (rule cong) apply simp
  apply (induct xs)
  apply (simp_all add: List.map_filter_def)
done

lemma set_iterator_image_alt_def [code] : 
  "set_iterator_image g it = (λc f. it c (λx. f (g x)))"
unfolding set_iterator_image_def
          set_iterator_image_filter_def[abs_def]
by simp

lemma set_iterator_genord_image_correct :
  fixes it :: "('a,) set_iterator"
  assumes it_OK: "set_iterator_genord it S R"
  assumes g_inj: "inj_on g S"
  assumes R'_prop: "x y. x  S; y  S; R x y  R' (g x) (g y)"
  shows "set_iterator_genord (set_iterator_image g it) (g ` S) R'"
proof -
  let ?g = "λx. Some (g x)"
  have set_eq: "S. {y . x. x  S  ?g x = Some y} = g ` S" by auto

  show ?thesis
    apply (rule set_iterator_genord_image_filter_correct [OF it_OK, of ?g R', 
     folded set_iterator_image_def set_eq[symmetric]])
    apply (insert g_inj, simp add: inj_on_def) []
    apply (insert R'_prop, auto)
  done
qed

lemma set_iterator_image_correct :
  assumes it_OK: "set_iterator it S"
  assumes g_inj: "inj_on g S"
  assumes S'_OK: "S' = g ` S"
  shows "set_iterator (set_iterator_image g it) S'"
proof -
  note res' = set_iterator_genord_image_correct [OF it_OK[unfolded set_iterator_def] g_inj, 
    of "λ_ _. True"]
  note res = set_iterator_intro [OF res', folded S'_OK]
  thus ?thesis by simp
qed



subsection ‹Construction from list (foldli)›

text ‹Iterators correspond by definition to iteration over distinct lists. They fix an order 
 in which the elements are visited. Therefore, it is trivial to construct an iterator from a 
 distinct list.›

lemma set_iterator_genord_foldli_correct :
"distinct xs  sorted_wrt R xs  set_iterator_genord (foldli xs) (set xs) R"
by (rule set_iterator_genord_I[of xs]) (simp_all)

lemma set_iterator_foldli_correct :
"distinct xs  set_iterator (foldli xs) (set xs)"
by (rule set_iterator_I[of xs]) (simp_all)

lemma (in linorder) set_iterator_linord_foldli_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted xs"
shows "set_iterator_linord (foldli xs) (set xs)"
using assms
by (rule_tac set_iterator_linord_I[of xs]) (simp_all)


lemma (in linorder) set_iterator_rev_linord_foldli_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted (rev xs)"
shows "set_iterator_rev_linord (foldli xs) (set xs)"
using assms
by (rule_tac set_iterator_rev_linord_I[of xs]) (simp_all)


lemma map_iterator_genord_foldli_correct :
"distinct (map fst xs)  sorted_wrt R xs  map_iterator_genord (foldli xs) (map_of xs) R"
by (rule map_iterator_genord_I[of xs]) simp_all

lemma map_iterator_foldli_correct :
"distinct (map fst xs)  map_iterator (foldli xs) (map_of xs)"
by (rule map_iterator_I[of xs]) (simp_all)

lemma (in linorder) map_iterator_linord_foldli_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (map fst xs)"
shows "map_iterator_linord (foldli xs) (map_of xs)"
using assms
by (rule_tac map_iterator_linord_I[of xs]) (simp_all)


lemma (in linorder) map_iterator_rev_linord_foldli_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (rev (map fst xs))"
shows "map_iterator_rev_linord (foldli xs) (map_of xs)"
using assms
by (rule_tac map_iterator_rev_linord_I[of xs]) (simp_all)


subsection ‹Construction from list (foldri)›

lemma set_iterator_genord_foldri_correct :
"distinct xs  sorted_wrt R (rev xs)  set_iterator_genord (foldri xs) (set xs) R"
by (rule set_iterator_genord_I[of "rev xs"]) (simp_all add: foldri_def)

lemma set_iterator_foldri_correct :
"distinct xs  set_iterator (foldri xs) (set xs)"
by (rule set_iterator_I[of "rev xs"]) (simp_all add: foldri_def)

lemma (in linorder) set_iterator_linord_foldri_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted (rev xs)"
shows "set_iterator_linord (foldri xs) (set xs)"
using assms
by (rule_tac set_iterator_linord_I[of "rev xs"]) (simp_all add: foldri_def)

lemma (in linorder) set_iterator_rev_linord_foldri_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted xs"
shows "set_iterator_rev_linord (foldri xs) (set xs)"
using assms
by (rule_tac set_iterator_rev_linord_I[of "rev xs"]) (simp_all add: foldri_def)

lemma map_iterator_genord_foldri_correct :
"distinct (map fst xs)  sorted_wrt R (rev xs)  map_iterator_genord (foldri xs) (map_of xs) R"
by (rule map_iterator_genord_I[of "rev xs"]) 
   (simp_all add: rev_map[symmetric] foldri_def)

lemma map_iterator_foldri_correct :
"distinct (map fst xs)  map_iterator (foldri xs) (map_of xs)"
by (rule map_iterator_I[of "rev xs"]) 
   (simp_all add: rev_map[symmetric] foldri_def)

lemma (in linorder) map_iterator_linord_foldri_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (rev (map fst xs))"
shows "map_iterator_linord (foldri xs) (map_of xs)"
using assms
by (rule_tac map_iterator_linord_I[of "rev xs"]) 
   (simp_all add: rev_map[symmetric] foldri_def)

lemma (in linorder) map_iterator_rev_linord_foldri_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (map fst xs)"
shows "map_iterator_rev_linord (foldri xs) (map_of xs)"
using assms
by (rule_tac map_iterator_rev_linord_I[of "rev xs"]) 
   (simp_all add: rev_map[symmetric] foldri_def)


subsection ‹Iterators over Maps›

text ‹In the following iterator over the key-value pairs of a finite map are called
 iterators over maps. Operations for such iterators are presented.›

subsubsection‹Domain Iterator›

text ‹One very simple such operation is iterating over only the keys of the map.›

definition map_iterator_dom where
  "map_iterator_dom it = set_iterator_image fst it"

lemma map_iterator_dom_foldli_conv :
  "map_iterator_dom (foldli kvs) = foldli (map fst kvs)"
unfolding map_iterator_dom_def set_iterator_image_foldli_conv by simp

lemma map_iterator_genord_dom_correct :
  assumes it_OK: "map_iterator_genord it m R"
  assumes R'_prop: "k v k' v'. m k = Some v; m k' = Some v'; R (k, v) (k', v')  R' k k'"
  shows "set_iterator_genord (map_iterator_dom it) (dom m) R'"
proof -
  have pre1: "inj_on fst (map_to_set m)" 
     unfolding inj_on_def map_to_set_def by simp

  from set_iterator_genord_image_correct[OF it_OK pre1, of R'] R'_prop
  show ?thesis
    unfolding map_iterator_dom_def map_to_set_dom[symmetric]
    by (auto simp add: map_to_set_def)
qed

lemma map_iterator_dom_correct :
  assumes it_OK: "map_iterator it m"
  shows "set_iterator (map_iterator_dom it) (dom m)"
using assms
unfolding set_iterator_def 
apply (rule_tac map_iterator_genord_dom_correct)
apply simp_all
done

lemma (in linorder) map_iterator_linord_dom_correct :
  assumes it_OK: "map_iterator_linord it m"
  shows "set_iterator_linord (map_iterator_dom it) (dom m)"
using assms
unfolding set_iterator_linord_def set_iterator_map_linord_def  
apply (rule_tac map_iterator_genord_dom_correct)
apply assumption
apply auto
done

lemma (in linorder) map_iterator_rev_linord_dom_correct :
  assumes it_OK: "map_iterator_rev_linord it m"
  shows "set_iterator_rev_linord (map_iterator_dom it) (dom m)"
using assms
unfolding set_iterator_rev_linord_def set_iterator_map_rev_linord_def
apply (rule_tac map_iterator_genord_dom_correct)
apply assumption
apply auto
done


subsubsection‹Domain Iterator with Filter›

text ‹More complex is iterating over only the keys such that the key-value pairs satisfy some
        property.›

definition map_iterator_dom_filter ::
    "('a × 'b  bool)  ('a × 'b,) set_iterator  ('a,) set_iterator" where
  "map_iterator_dom_filter P it  set_iterator_image_filter 
     (λxy. if P xy then Some (fst xy) else None) it"

lemma map_iterator_dom_filter_alt_def [code] :
  "map_iterator_dom_filter P it = 
   (λc f. it c (λkv σ. if P kv then f (fst kv) σ else σ))"
unfolding map_iterator_dom_filter_def set_iterator_image_filter_def
apply (rule ext)
apply (rule ext)
apply (rule arg_cong2[where f="it"])
apply (simp)
apply (simp add: fun_eq_iff split: option.splits)
done

lemma map_iterator_genord_dom_filter_correct :
  fixes it :: "('a × 'b, ) set_iterator"
  assumes it_OK: "set_iterator_genord it (map_to_set m) R"
  assumes R'_prop: "k1 v1 k2 v2.
      m k1 = Some v1; P (k1, v1);
       m k2 = Some v2; P (k2, v2); R (k1, v1) (k2, v2)  R' k1 k2"
  shows "set_iterator_genord (map_iterator_dom_filter P it) {k . v. m k = Some v  P (k, v)} R'"
proof - 
  define g where "g xy = (if P xy then Some (fst xy) else None)" for xy :: "'a × 'b"

  note set_iterator_genord_image_filter_correct [OF it_OK, of g R']

  have g_eq_Some: "kv k. g kv = Some k  ((k = fst kv)  P kv)"
    unfolding g_def by (auto split: prod.splits option.splits)

  have "x1 x2 y. x1  map_to_set m  x2  map_to_set m 
                  g x1 = Some y  g x2 = Some y  x1 = x2"
  proof -
    fix x1 x2 y
    assume x1_in: "x1  map_to_set m"
       and x2_in: "x2  map_to_set m"
       and g1_eq: "g x1 = Some y" 
       and g2_eq: "g x2 = Some y"

    obtain k1 v1 where x1_eq[simp] : "x1 = (k1, v1)" by (rule prod.exhaust)
    obtain k2 v2 where x2_eq[simp] : "x2 = (k2, v2)" by (rule prod.exhaust)

    from g1_eq g2_eq g_eq_Some have k1_eq: "k1 = k2" by simp 
    with x1_in x2_in have v1_eq: "v1 = v2"
      unfolding map_to_set_def by simp
    from k1_eq v1_eq show "x1 = x2" by simp
  qed
  hence g_inj_on: "inj_on g (map_to_set m  dom g)"
    unfolding inj_on_def dom_def by auto

  have g_eq_Some: "x y. (g x = Some y)  (P x  y = (fst x))"
    unfolding g_def by auto

  have "set_iterator_genord (set_iterator_image_filter g it)
            {y. x. x  map_to_set m  g x = Some y} R'" 
    apply (rule set_iterator_genord_image_filter_correct [OF it_OK, of g R', OF g_inj_on])
    apply (insert R'_prop) 
    apply (auto simp add: g_eq_Some map_to_set_def)
  done
  thus ?thesis
    unfolding map_iterator_dom_filter_def g_def[symmetric]
    by (simp add: g_eq_Some map_to_set_def)
qed

lemma map_iterator_dom_filter_correct :
  assumes it_OK: "map_iterator it m"
  shows "set_iterator (map_iterator_dom_filter P it) {k. v. m k = Some v  P (k, v)}"
using assms
unfolding set_iterator_def
apply (rule_tac map_iterator_genord_dom_filter_correct)
apply simp_all
done

lemma (in linorder) map_iterator_linord_dom_filter_correct :
  assumes it_OK: "map_iterator_linord it m"
  shows "set_iterator_linord (map_iterator_dom_filter P it) {k. v. m k = Some v  P (k, v)}"
using assms
unfolding set_iterator_map_linord_def set_iterator_linord_def 
apply (rule_tac map_iterator_genord_dom_filter_correct 
  [where R = "λ(k,_) (k',_). kk'"])
apply (simp_all add: set_iterator_def)
done

lemma (in linorder) set_iterator_rev_linord_map_filter_correct :
  assumes it_OK: "map_iterator_rev_linord it m"
  shows "set_iterator_rev_linord (map_iterator_dom_filter P it) 
  {k. v. m k = Some v  P (k, v)}"
using assms
unfolding set_iterator_map_rev_linord_def set_iterator_rev_linord_def 
apply (rule_tac map_iterator_genord_dom_filter_correct 
  [where R = "λ(k,_) (k',_). kk'"])
apply (simp_all add: set_iterator_def)
done


subsubsection‹Product for Maps›

definition map_iterator_product where
  "map_iterator_product it_a it_b =
   set_iterator_image (λkvv'. (fst (fst kvv'), snd kvv')) 
    (set_iterator_product it_a (λkv. it_b (snd kv)))"

lemma map_iterator_product_foldli_conv :
"map_iterator_product (foldli as) (λa. foldli (bs a)) = 
 foldli (concat (map (λ(k, v). map (Pair k) (bs v)) as))"
unfolding map_iterator_product_def set_iterator_product_foldli_conv set_iterator_image_foldli_conv
by (simp add: map_concat o_def split_def) 

lemma map_iterator_product_alt_def [code] :
  "map_iterator_product it_a it_b = 
   (λc f. it_a c (λa. it_b (snd a) c (λb. f (fst a, b))))"
unfolding map_iterator_product_def set_iterator_product_def set_iterator_image_alt_def
by simp

lemma map_iterator_genord_product_correct :
  fixes it_a :: "(('k × 'v),) set_iterator"
  fixes it_b :: "'v  ('e,) set_iterator" 
  fixes S_a S_b R_a R_b m
  assumes it_a: "map_iterator_genord it_a m R_a"
  assumes it_b: "k v. m k = Some v  set_iterator_genord (it_b v) (S_b v) (R_b v)"
  assumes R'_prop: "k v u k' v' u'.
       m k = Some v 
       u  S_b v 
       m k' = Some v' 
       u'  S_b v' 
       if k = k' then R_b v u u'
       else R_a (k, v) (k', v') 
       R_ab (k, u) (k', u')"
  shows "set_iterator_genord (map_iterator_product it_a it_b) 
     {(k, e) . (v. m k = Some v  e  S_b v)} R_ab"
proof -
  from it_b have it_b': "kv. kv  map_to_set m 
       set_iterator_genord (it_b (snd kv)) (S_b (snd kv)) (R_b (snd kv))"
    unfolding map_to_set_def by (case_tac kv, simp)

  have "(x{(k, v). m k = Some v}. yS_b (snd x). {(x, y)}) = {((k,v), e) . 
          (m k = Some v)  e  S_b v}" by (auto)
  with set_iterator_genord_product_correct [OF it_a, of "λkv. it_b (snd kv)" 
    "λkv. S_b (snd kv)" "λkv. R_b (snd kv)", OF it_b']
  have it_ab': "set_iterator_genord (set_iterator_product it_a (λkv. it_b (snd kv)))
      {((k,v), e) . (m k = Some v)  e  S_b v}
      (set_iterator_product_order R_a
        (λkv. R_b (snd kv)))"
     (is "set_iterator_genord ?it_ab' ?S_ab' ?R_ab'")
    unfolding map_to_set_def
    by (simp add: Sigma_def)

  let ?g = "λkvv'. (fst (fst kvv'), snd kvv')"
  have inj_g: "inj_on ?g ?S_ab'"
    unfolding inj_on_def by simp

  have R_ab_OK: "x y.
      x  {((k, v), e). m k = Some v  e  S_b v} 
      y  {((k, v), e). m k = Some v  e  S_b v} 
      set_iterator_product_order R_a (λkv. R_b (snd kv)) x y 
      R_ab (fst (fst x), snd x) (fst (fst y), snd y)"
    apply (simp add: set_iterator_product_order_def)
    apply clarify
    apply (simp)
    apply (unfold fst_conv snd_conv)
    apply (metis R'_prop option.inject)
  done

  have "(?g ` {((k, v), e). m k = Some v  e  S_b v}) = {(k, e). v. m k = Some v  e  S_b v}" 
    by (simp add: image_iff set_eq_iff)
  with set_iterator_genord_image_correct [OF it_ab' inj_g, of R_ab, OF R_ab_OK]
  show ?thesis 
    by (simp add: map_iterator_product_def)
qed

lemma map_iterator_product_correct :
  assumes it_a: "map_iterator it_a m"
  assumes it_b: "k v. m k = Some v  set_iterator (it_b v) (S_b v)"
  shows "set_iterator (map_iterator_product it_a it_b) 
         {(k, e) . (v. m k = Some v  e  S_b v)}"
proof -
  note res' = map_iterator_genord_product_correct [OF it_a[unfolded set_iterator_def], 
     of it_b S_b "λ_ _ _. True"]
  note res = set_iterator_intro [OF res']
  with it_b show ?thesis unfolding set_iterator_def by simp
qed

  
subsubsection‹Key Filter›

definition map_iterator_key_filter ::
    "('a  bool)  ('a × 'b,) set_iterator  ('a × 'b,) set_iterator" where
  "map_iterator_key_filter P  set_iterator_filter (P  fst)"

lemma map_iterator_key_filter_foldli_conv :
  "map_iterator_key_filter P (foldli kvs) =  foldli (filter (λ(k, v). P k) kvs)"
unfolding map_iterator_key_filter_def set_iterator_filter_foldli_conv o_def split_def 
by simp

lemma map_iterator_key_filter_alt_def [code] :
  "map_iterator_key_filter P it = (λc f. it c (λx σ. if P (fst x) then f x σ else σ))"
unfolding map_iterator_key_filter_def set_iterator_filter_alt_def
  set_iterator_image_filter_def by simp

lemma map_iterator_genord_key_filter_correct :
  fixes it :: "('a × 'b, ) set_iterator"
  assumes it_OK: "map_iterator_genord it m R"
  shows "map_iterator_genord (map_iterator_key_filter P it) (m |` {k . P k}) R"
proof - 
  from set_iterator_genord_filter_correct [OF it_OK, of "P  fst", 
    folded map_iterator_key_filter_def] 
  have step1: "set_iterator_genord (map_iterator_key_filter P it)
                  {x  map_to_set m. (P  fst) x} R" 
    by simp

  have "{x  map_to_set m. (P  fst) x} = map_to_set (m |` {k . P k})"
    unfolding map_to_set_def restrict_map_def
    by (auto split: if_splits)
  with step1 show ?thesis by simp
qed

lemma map_iterator_key_filter_correct :
  assumes it_OK: "map_iterator it m"
  shows "set_iterator (map_iterator_key_filter P it) (map_to_set (m |` {k . P k}))"
using assms
unfolding set_iterator_def
apply (rule_tac map_iterator_genord_key_filter_correct)
apply simp_all
done

end


Theory Proper_Iterator

section ‹Proper Iterators›
theory Proper_Iterator
imports 
  SetIteratorOperations 
  Automatic_Refinement.Refine_Lib
begin
  text ‹
    Proper iterators provide a way to obtain polymorphic iterators even
    inside locale contexts.

    For this purpose, an iterator that converts the set to a list is fixed
    inside the locale, and polymorphic iterators are described by folding
    over the generated list.

    In order to ensure efficiency, it is shown that folding over the generated
    list is equivalent to directly iterating over the set, and this equivalence
    is set up as a code preprocessing rule.
›

  subsection ‹Proper Iterators›

  text ‹A proper iterator can be expressed as a fold over a list, where
    the list does only depend on the set. In particular, it does not depend
    on the type of the state. We express this by the following definition, 
    using two iterators with different types:›

  definition proper_it 
    :: "('x,'σ1) set_iterator  ('x,'σ2) set_iterator  bool"
    where "proper_it it it'  (l. it=foldli l  it'=foldli l)"

  lemma proper_itI[intro?]:
    fixes it :: "('x,'σ1) set_iterator" 
    and it' :: "('x,'σ2) set_iterator"
    assumes "it=foldli l  it'=foldli l"
    shows "proper_it it it'"
    using assms unfolding proper_it_def by auto

  lemma proper_itE:
    fixes it :: "('x,'σ1) set_iterator" 
    and it' :: "('x,'σ2) set_iterator"
    assumes "proper_it it it'"
    obtains l where "it=foldli l" and "it'=foldli l"
    using assms unfolding proper_it_def by auto

  lemma proper_it_parE:
    fixes it :: "'a  ('x,'σ1) set_iterator" 
    and it' :: "'a  ('x,'σ2) set_iterator"
    assumes "x. proper_it (it x) (it' x)"
    obtains f where "it = (λx. foldli (f x))" and "it' = (λx. foldli (f x))"
    using assms unfolding proper_it_def
    by metis

  definition 
    proper_it'
    where "proper_it' it it'  s. proper_it (it s) (it' s)"

  lemma proper_it'I:
    "s. proper_it (it s) (it' s)  proper_it' it it'"
    unfolding proper_it'_def by blast

  lemma proper_it'D:
    "proper_it' it it'  proper_it (it s) (it' s)"
    unfolding proper_it'_def by blast





  subsubsection ‹Properness Preservation›
  ML structure Icf_Proper_Iterator = struct

      structure icf_proper_iteratorI = Named_Thms
        ( val name = @{binding icf_proper_iteratorI_raw}
          val description = "ICF (internal): Rules to show properness of iterators" )

      val get = icf_proper_iteratorI.get
  
      fun add_thm thm = icf_proper_iteratorI.add_thm thm
  
      val add = Thm.declaration_attribute add_thm

      fun del_thm thm = icf_proper_iteratorI.del_thm thm

      val del = Thm.declaration_attribute del_thm

      val setup = I
        #> icf_proper_iteratorI.setup
        #> Attrib.setup @{binding icf_proper_iteratorI} 
          (Attrib.add_del add del) 
          ("ICF: Rules to show properness of iterators")
        #> Global_Theory.add_thms_dynamic (@{binding icf_proper_iteratorI}, 
             get o Context.proof_of
            )
        
  
    end
  setup Icf_Proper_Iterator.setup

  lemma proper_iterator_trigger: 
    "proper_it it it'  proper_it it it'"
    "proper_it' itf itf'  proper_it' itf itf'" .

  declaration Tagged_Solver.declare_solver @{thms proper_iterator_trigger} 
      @{binding proper_iterator} "Proper iterator solver"
      (fn ctxt => REPEAT_ALL_NEW (resolve_tac ctxt (Icf_Proper_Iterator.get ctxt)))

  lemma pi_foldli[icf_proper_iteratorI]: 
    "proper_it (foldli l :: ('a,) set_iterator) (foldli l)"
    unfolding proper_it_def 
    by auto

  lemma pi_foldri[icf_proper_iteratorI]: 
    "proper_it (foldri l :: ('a,) set_iterator) (foldri l)"
    unfolding proper_it_def foldri_def by auto

  lemma pi'_foldli[icf_proper_iteratorI]: 
    "proper_it' (foldli o tsl) (foldli o tsl)"
    apply (clarsimp simp add: proper_it'_def)
    apply (tagged_solver)
    done

  lemma pi'_foldri[icf_proper_iteratorI]: 
    "proper_it' (foldri o tsl) (foldri o tsl)"
    apply (clarsimp simp add: proper_it'_def)
    apply (tagged_solver)
    done

  text ‹Iterator combinators preserve properness›
  lemma pi_emp[icf_proper_iteratorI]: 
    "proper_it set_iterator_emp set_iterator_emp"
    unfolding proper_it_def set_iterator_emp_def[abs_def]
    by (auto intro!: ext exI[where x="[]"])

  lemma pi_sng[icf_proper_iteratorI]:
    "proper_it (set_iterator_sng x) (set_iterator_sng x)"
    unfolding proper_it_def set_iterator_sng_def[abs_def]
    by (auto intro!: ext exI[where x="[x]"])

  lemma pi_union[icf_proper_iteratorI]:
    assumes PA: "proper_it it_a it_a'"
    assumes PB: "proper_it it_b it_b'"
    shows "proper_it (set_iterator_union it_a it_b)
      (set_iterator_union it_a' it_b')"
    unfolding set_iterator_union_def
    apply (rule proper_itE[OF PA])
    apply (rule proper_itE[OF PB])
    apply (rule_tac l="l@la" in proper_itI)
    apply simp
    apply (intro conjI ext)
    apply (simp_all add: foldli_append)
    done

  lemma pi_product[icf_proper_iteratorI]:
    fixes it_a :: "('a,'σa) set_iterator"
    fixes it_b :: "'a  ('b,'σa) set_iterator"
    assumes PA: "proper_it it_a it_a'"
    and PB: "x. proper_it (it_b x) (it_b' x)"
    shows "proper_it (set_iterator_product it_a it_b)
      (set_iterator_product it_a' it_b')"
  proof -
    from PB have PB': "x. proper_it (it_b x) (it_b' x)" ..
    show ?thesis
      unfolding proper_it_def
      apply (rule proper_itE[OF PA])
      apply (rule proper_it_parE[OF PB'])
      apply (auto simp add: set_iterator_product_foldli_conv)
      done
  qed

  lemma pi_image_filter[icf_proper_iteratorI]:
    fixes it :: "('x,'σ1) set_iterator" 
    and it' :: "('x,'σ2) set_iterator"
    and g :: "'x  'y option"
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_image_filter g it) 
      (set_iterator_image_filter g it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    apply (auto simp: set_iterator_image_filter_foldli_conv)
    done

  lemma pi_filter[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_filter P it) 
      (set_iterator_filter P it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: set_iterator_filter_foldli_conv)

  lemma pi_image[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (set_iterator_image g it) 
      (set_iterator_image g it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: set_iterator_image_foldli_conv)

  lemma pi_dom[icf_proper_iteratorI]:
    assumes P: "proper_it it it'"
    shows "proper_it (map_iterator_dom it) 
      (map_iterator_dom it')"
    unfolding proper_it_def
    apply (rule proper_itE[OF P])
    by (auto simp: map_iterator_dom_foldli_conv)

  lemma set_iterator_product_eq2:
    assumes "aset la. itb a = itb' a"
    shows "set_iterator_product (foldli la) itb
    = set_iterator_product (foldli la) itb'"
  proof (intro ext)
    fix c f σ
    show "set_iterator_product (foldli la) itb c f σ
      = set_iterator_product (foldli la) itb' c f σ"
      using assms
      unfolding set_iterator_product_def
      apply (induct la arbitrary: σ)
      apply (auto)
      done
  qed


subsubsection ‹Optimizing Folds›
  text ‹
    Using an iterator to create a list. The optimizations will
    match the pattern foldli (it_to_list it s)›
  definition "it_to_list it s  (it s) (λ_. True) (λx l. l@[x]) []"

  lemma map_it_to_list_genord_correct:
    assumes A: "map_iterator_genord (it s) m (λ(k,_) (k',_). R k k')"
    shows "map_of (it_to_list it s) = m
       distinct (map fst (it_to_list it s))
       sorted_wrt R ((map fst (it_to_list it s)))"
    unfolding it_to_list_def
    apply (rule map_iterator_genord_rule_insert_P[OF A, where I="
      λit l. map_of l = m |` it 
         distinct (map fst l) 
         sorted_wrt R ((map fst l))
      "])
    apply auto
    apply (auto simp: restrict_map_def) []
    apply (metis Some_eq_map_of_iff restrict_map_eq(2))
    apply (auto simp add: sorted_wrt_append)
    by (metis (lifting) restrict_map_eq(2) weak_map_of_SomeI)

  lemma (in linorder) map_it_to_list_linord_correct:
    assumes A: "map_iterator_linord (it s) m"
    shows "map_of (it_to_list it s) = m
       distinct (map fst (it_to_list it s))
       sorted ((map fst (it_to_list it s)))"
    using map_it_to_list_genord_correct[where it=it,
      OF A[unfolded set_iterator_map_linord_def]]
    by (simp add: sorted_sorted_wrt)

  lemma (in linorder) map_it_to_list_rev_linord_correct:
    assumes A: "map_iterator_rev_linord (it s) m"
    shows "map_of (it_to_list it s) = m
       distinct (map fst (it_to_list it s))
       sorted (rev (map fst (it_to_list it s)))"
    using map_it_to_list_genord_correct[where it=it,
      OF A[unfolded set_iterator_map_rev_linord_def]]
    by simp

 
end

Theory It_to_It

theory It_to_It
imports 
  Proper_Iterator
begin

  lemma proper_it_fold: 
    "proper_it it it'  foldli (it (λ_. True) (λx l. l@[x]) []) = it'"
    unfolding proper_it_def by auto
  lemma proper_it_unfold: 
    "proper_it it it'  it' = foldli (it (λ_. True) (λx l. l@[x]) [])"
    unfolding proper_it_def by auto


  text ‹The following constant converts an iterator over list-state
    to an iterator over arbitrary state›
  definition it_to_it :: "('x,'x list) set_iterator  ('x,) set_iterator"
    where [code del]: "it_to_it it 
     (foldli (it (λ_. True) (λx l. l@[x]) []))"

  lemma pi_it_to_it[icf_proper_iteratorI]: "proper_it (it_to_it I) (it_to_it I)"
    unfolding it_to_it_def by (rule pi_foldli)
  text ‹In case of a proper iterator, it is equivalent to direct iteration›
  lemma it_to_it_fold: "proper_it it (it'::('x,) set_iterator) 
     it_to_it it = it'"
    unfolding it_to_it_def
    by (simp add: proper_it_fold)

  lemma it_to_it_map_fold:
    assumes P: "proper_it it it'"
    shows "it_to_it (λc f. it c (f  f')) = (λc f. it' c (f o f'))"
    apply (rule proper_itE[OF P])
    unfolding it_to_it_def
    apply (intro ext)
    apply (simp add: foldli_foldl map_by_foldl foldli_map)
    done

  lemma it_to_it_fold': "proper_it' it (it'::'s  ('x,) set_iterator) 
     it_to_it (it s) = (it' s)"
    by (drule proper_it'D) (rule it_to_it_fold)

  lemma it_to_it_map_fold':
    assumes P: "proper_it' it it'"
    shows "it_to_it (λc f. it s c (f  f')) = (λc f. it' s c (f o f'))"
    using P[THEN proper_it'D] by (rule it_to_it_map_fold)

  text ‹This locale wraps up the setup of a proper iterator for use
    with it_to_it›.›
  locale proper_it_loc =
    fixes it :: "'s  ('x,'x list) set_iterator"
    and it' :: "'s  ('x,) set_iterator"
    assumes proper': "proper_it' it it'"
  begin
    lemma proper: "proper_it (it s) (it' s)"
      using proper' by (rule proper_it'D)

    lemmas it_to_it_code_unfold[code_unfold] = it_to_it_fold[OF proper]
  end

  subsubsection ‹Correctness›
  text ‹The polymorphic iterator is a valid iterator again.›
  lemma it_to_it_genord_correct: 
    assumes "set_iterator_genord (it::('x,'x list) set_iterator) S R" 
    shows "set_iterator_genord ((it_to_it it)::('x,) set_iterator) S R"
  proof -
    interpret set_iterator_genord it S R by fact

    show ?thesis
      apply (unfold_locales)
      unfolding it_to_it_def
      using foldli_transform
      by auto
  qed

  lemma it_to_it_linord_correct: 
    assumes "set_iterator_linord (it::('x::linorder,'x list) set_iterator) S" 
    shows "set_iterator_linord ((it_to_it it)::('x,) set_iterator) S"
    using assms
    unfolding set_iterator_linord_def
    by (rule it_to_it_genord_correct)

  lemma it_to_it_rev_linord_correct: 
    assumes "set_iterator_rev_linord (it::('x::linorder,'x list) set_iterator) S"
    shows "set_iterator_rev_linord ((it_to_it it)::('x,) set_iterator) S"
    using assms
    unfolding set_iterator_rev_linord_def
    by (rule it_to_it_genord_correct)

  lemma it_to_it_correct: 
    assumes "set_iterator (it::('x,'x list) set_iterator) S" 
    shows "set_iterator ((it_to_it it)::('x,) set_iterator) S"
    using assms
    unfolding set_iterator_def
    by (rule it_to_it_genord_correct)

  lemma it_to_it_map_genord_correct:
    assumes "map_iterator_genord (it::('u,'v,('u×'v) list) map_iterator) S R" 
    shows "map_iterator_genord ((it_to_it it)::('u,'v,) map_iterator) S R"
    using assms by (rule it_to_it_genord_correct)

  lemma it_to_it_map_linord_correct:
    assumes "map_iterator_linord (it::('u::linorder,'v,('u×'v) list) map_iterator) S" 
    shows "map_iterator_linord ((it_to_it it)::('u,'v,) map_iterator) S"
    using assms unfolding set_iterator_map_linord_def by (rule it_to_it_genord_correct)

  lemma it_to_it_map_rev_linord_correct:
    assumes 
      "map_iterator_rev_linord (it::('u::linorder,'v,('u×'v) list) map_iterator) S" 
    shows "map_iterator_rev_linord ((it_to_it it)::('u,'v,) map_iterator) S"
    using assms unfolding set_iterator_map_rev_linord_def 
    by (rule it_to_it_genord_correct)

  lemma it_to_it_map_correct:
    assumes "map_iterator (it::('u,'v,('u×'v) list) map_iterator) S" 
    shows "map_iterator ((it_to_it it)::('u,'v,) map_iterator) S"
    using assms by (rule it_to_it_correct)






end

Theory SetIteratorGA

(*  Title:       General Algorithms for Iterators
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section ‹General Algorithms for Iterators over Finite Sets›
theory SetIteratorGA
imports Main SetIteratorOperations
begin

subsection ‹Quantification›

definition iterate_ball where
    "iterate_ball (it::('x,bool) set_iterator) P = it id (λx σ. P x) True"

lemma iterate_ball_correct :
assumes it: "set_iterator it S0"
shows "iterate_ball it P = (xS0. P x)"
unfolding iterate_ball_def
apply (rule set_iterator_rule_P [OF it,
            where I = "λS σ. σ = (xS0-S. P x)"])
apply auto
done

definition iterate_bex where
    "iterate_bex (it::('x,bool) set_iterator) P = it (λσ. ¬σ) (λx σ. P x) False"

lemma iterate_bex_correct :
assumes it: "set_iterator it S0"
shows "iterate_bex it P = (xS0. P x)"
unfolding iterate_bex_def
apply (rule set_iterator_rule_P [OF it, where I = "λS σ. σ = (xS0-S. P x)"])
apply auto
done

subsection ‹Iterator to List›

definition iterate_to_list where
    "iterate_to_list (it::('x,'x list) set_iterator) = it (λ_. True) (λx σ. x # σ) []"

lemma iterate_to_list_foldli [simp] :
  "iterate_to_list (foldli xs) = rev xs"
unfolding iterate_to_list_def
by (induct xs rule: rev_induct, simp_all add: foldli_snoc) 

lemma iterate_to_list_genord_correct :
assumes it: "set_iterator_genord it S0 R"
shows "set (iterate_to_list it) = S0  distinct (iterate_to_list it) 
       sorted_wrt R (rev (iterate_to_list it))"
using it unfolding set_iterator_genord_foldli_conv by auto

lemma iterate_to_list_correct :
assumes it: "set_iterator it S0"
shows "set (iterate_to_list it) = S0  distinct (iterate_to_list it)"
using iterate_to_list_genord_correct [OF it[unfolded set_iterator_def]]
by simp

lemma (in linorder) iterate_to_list_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_linord it S0"
shows "set (iterate_to_list it) = S0  distinct (iterate_to_list it) 
       sorted (rev (iterate_to_list it))"
using it_OK unfolding set_iterator_linord_foldli_conv by auto

lemma (in linorder) iterate_to_list_rev_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_rev_linord it S0"
shows "set (iterate_to_list it) = S0  distinct (iterate_to_list it) 
       sorted (iterate_to_list it)"
using it_OK unfolding set_iterator_rev_linord_foldli_conv by auto

lemma (in linorder) iterate_to_list_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "map_of (iterate_to_list it) = m  distinct (map fst (iterate_to_list it)) 
       sorted (map fst (rev (iterate_to_list it)))"
using it_OK unfolding map_iterator_linord_foldli_conv 
by clarify (simp add: rev_map[symmetric])

lemma (in linorder) iterate_to_list_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "map_of (iterate_to_list it) = m  distinct (map fst (iterate_to_list it)) 
       sorted (map fst (iterate_to_list it))"
using it_OK unfolding map_iterator_rev_linord_foldli_conv 
by clarify (simp add: rev_map[symmetric])


subsection ‹Size›

lemma set_iterator_finite :
assumes it: "set_iterator it S0"
shows "finite S0"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]] .

lemma map_iterator_finite :
assumes it: "map_iterator it m"
shows "finite (dom m)"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
by (simp add: finite_map_to_set) 

definition iterate_size where
    "iterate_size (it::('x,nat) set_iterator) = it (λ_. True) (λx σ. Suc σ) 0"

lemma iterate_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_size it = card S0  finite S0"
unfolding iterate_size_def
apply (rule_tac set_iterator_rule_insert_P [OF it, 
    where I = "λS σ. σ = card S  finite S"])
apply auto
done

definition iterate_size_abort where
  "iterate_size_abort (it::('x,nat) set_iterator) n = it (λσ. σ < n) (λx σ. Suc σ) 0"

lemma iterate_size_abort_correct :
assumes it: "set_iterator it S0"
shows "iterate_size_abort it n = (min n (card S0))  finite S0"
unfolding iterate_size_abort_def
proof (rule set_iterator_rule_insert_P [OF it,
   where I = "λS σ. σ = (min n (card S))  finite S"], goal_cases)
  case (4 σ S)
  assume "S  S0" "S  S0" "¬ σ < n" "σ = min n (card S)  finite S" 

  from σ = min n (card S)  finite S ¬ σ < n 
  have "σ = n" "n  card S"
    by (auto simp add: min_less_iff_disj)

  note fin_S0 = set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
  from card_mono [OF fin_S0 S  S0] have "card S  card S0" .
  
  with σ = n n  card S fin_S0
  show "σ = min n (card S0)  finite S0" by simp
qed simp_all

subsection ‹Emptyness Check›

definition iterate_is_empty_by_size where
    "iterate_is_empty_by_size it = (iterate_size_abort it 1 = 0)"

lemma iterate_is_empty_by_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty_by_size it = (S0 = {})"
using iterate_size_abort_correct[OF it, of 1]
unfolding iterate_is_empty_by_size_def
by (cases "card S0") auto

definition iterate_is_empty where
    "iterate_is_empty (it::('x,bool) set_iterator) = (it (λb. b) (λ_ _. False) True)"

lemma iterate_is_empty_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty it = (S0 = {})"
unfolding iterate_is_empty_def
apply (rule set_iterator_rule_insert_P [OF it,
   where I = "λS σ. σ  S = {}"])
apply auto
done

subsection ‹Check for singleton Sets›

definition iterate_is_sng where
    "iterate_is_sng it = (iterate_size_abort it 2 = 1)"

lemma iterate_is_sng_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_sng it = (card S0 = 1)"
using iterate_size_abort_correct[OF it, of 2]
unfolding iterate_is_sng_def
apply (cases "card S0", simp, rename_tac n')
apply (case_tac n')
apply auto
done

subsection ‹Selection›

definition iterate_sel where
    "iterate_sel (it::('x,'y option) set_iterator) f = it (λσ. σ = None) (λx σ. f x) None"

lemma iterate_sel_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel it f = None  (xS0. (f x = None))"
      "iterate_sel it f = Some y  (x  S0. f x = Some y  (x'  S0-{x}. y. f x' = Some y'  R x x'))"
proof -
  show "iterate_sel it f = None  (xS0. (f x = None))"
    unfolding iterate_sel_def
    apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK, 
       where I = "λS σ. (σ = None)  (xS. (f x = None))"])
    apply auto
  done
next
  have "iterate_sel it f = Some y  (x  S0. f x = Some y  (x'  S0-{x}. y'. f x' = Some y'  R x x'))"
    unfolding iterate_sel_def
    apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK, 
       where I = "λS σ. (y. σ = Some y  (x  S. f x = Some y  (x'  S-{x}.y'. f x' = Some y'  R x x'))) 
                        ((σ = None)  (xS. f x = None))"])
    apply simp
    apply (auto simp add: Bex_def subset_iff Ball_def)
    apply metis
  done
  moreover assume "iterate_sel it f = Some y" 
  finally show "(x  S0. f x = Some y  (x'  S0-{x}. y. f x' = Some y'  R x x'))" by blast
qed


definition iterate_sel_no_map where
    "iterate_sel_no_map it P = iterate_sel it (λx. if P x then Some x else None)" 
lemmas iterate_sel_no_map_alt_def = iterate_sel_no_map_def[unfolded iterate_sel_def, code]

lemma iterate_sel_no_map_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel_no_map it P = None  (xS0. ¬(P x))"
      "iterate_sel_no_map it P = Some x  (x  S0  P x  (x'  S0-{x}. P x'  R x x'))"
unfolding iterate_sel_no_map_def
using iterate_sel_genord_correct[OF it_OK, of "λx. if P x then Some x else None"]
apply (simp_all add: Bex_def)
apply (metis option.inject option.simps(2)) 
done

lemma iterate_sel_no_map_correct :
assumes it_OK: "set_iterator it S0"
shows "iterate_sel_no_map it P = None  (xS0. ¬(P x))"
      "iterate_sel_no_map it P = Some x  x  S0  P x"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
  thus "iterate_sel_no_map it P = None  (xS0. ¬(P x))"
       "iterate_sel_no_map it P = Some x  x  S0  P x"
    by simp_all
qed

lemma (in linorder) iterate_sel_no_map_linord_correct :
assumes it_OK: "set_iterator_linord it S0"
shows "iterate_sel_no_map it P = None  (xS0. ¬(P x))"
      "iterate_sel_no_map it P = Some x  (x  S0  P x  (x'S0. P x'  x  x'))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_linord_def], of P]
  thus "iterate_sel_no_map it P = None  (xS0. ¬(P x))"
       "iterate_sel_no_map it P = Some x  (x  S0  P x  (x'S0. P x'  x  x'))"
    by auto
qed

lemma (in linorder) iterate_sel_no_map_rev_linord_correct :
assumes it_OK: "set_iterator_rev_linord it S0"
shows "iterate_sel_no_map it P = None  (xS0. ¬(P x))"
      "iterate_sel_no_map it P = Some x  (x  S0  P x  (x'S0. P x'  x'  x))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_rev_linord_def], of P]
  thus "iterate_sel_no_map it P = None  (xS0. ¬(P x))"
       "iterate_sel_no_map it P = Some x  (x  S0  P x  (x'S0. P x'  x'  x))"
    by auto
qed


lemma iterate_sel_no_map_map_correct :
assumes it_OK: "map_iterator it m"
shows "iterate_sel_no_map it P = None  (k v. m k = Some v  ¬(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v)  (m k = Some v  P (k, v))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
  thus "iterate_sel_no_map it P = None  (k v. m k = Some v  ¬(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v)  (m k = Some v  P (k, v))"
    by (auto simp add: map_to_set_def)
qed

lemma (in linorder) iterate_sel_no_map_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "iterate_sel_no_map it P = None  (k v. m k = Some v  ¬(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v)  (m k = Some v  P (k, v)  (k' v' . m k' = Some v' 
           P (k', v')  k  k'))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_linord_def], of P]
  thus "iterate_sel_no_map it P = None  (k v. m k = Some v  ¬(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v)  (m k = Some v  P (k, v)  (k' v' . m k' = Some v' 
           P (k', v')  k  k'))"
    apply (auto simp add: map_to_set_def Ball_def) 
  done
qed

lemma (in linorder) iterate_sel_no_map_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "iterate_sel_no_map it P = None  (k v. m k = Some v  ¬(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v)  (m k = Some v  P (k, v)  (k' v' . m k' = Some v' 
           P (k', v')  k'  k))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_rev_linord_def], of P]
  thus "iterate_sel_no_map it P = None  (k v. m k = Some v  ¬(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v)  (m k = Some v  P (k, v)  (k' v' . m k' = Some v' 
           P (k', v')  k'  k))"
    apply (auto simp add: map_to_set_def Ball_def) 
  done
qed


subsection ‹Creating ordered iterators›

text ‹One can transform an iterator into an ordered one by converting it to list, 
        sorting this list and then converting back to an iterator. In general, this brute-force
        method is inefficient, though.›

definition iterator_to_ordered_iterator where
  "iterator_to_ordered_iterator sort_fun it =
   foldli (sort_fun (iterate_to_list it))"

lemma iterator_to_ordered_iterator_correct :
assumes sort_fun_OK: "l. sorted_wrt R (sort_fun l)  mset (sort_fun l) = mset l"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator sort_fun it) S0 R"
proof -
  define l where "l = iterate_to_list it"
  have l_props: "set l = S0" "distinct l" 
    using iterate_to_list_correct [OF it_OK, folded l_def] by simp_all

  with sort_fun_OK[of l] have sort_l_props:
    "sorted_wrt R (sort_fun l)"
    "set (sort_fun l) = S0" "distinct (sort_fun l)"
    apply (simp_all)
    apply (metis set_mset_mset)
    apply (metis distinct_count_atmost_1 set_mset_mset)
  done

  show ?thesis
    apply (rule set_iterator_genord_I[of "sort_fun l"])
    apply (simp_all add: sort_l_props iterator_to_ordered_iterator_def l_def[symmetric])
  done
qed


definition iterator_to_ordered_iterator_quicksort where
  "iterator_to_ordered_iterator_quicksort R it =
   iterator_to_ordered_iterator (quicksort_by_rel R []) it"

lemmas iterator_to_ordered_iterator_quicksort_code[code] =
  iterator_to_ordered_iterator_quicksort_def[unfolded iterator_to_ordered_iterator_def]

lemma iterator_to_ordered_iterator_quicksort_correct :
assumes lin : "x y. (R x y)  (R y x)"
    and trans_R: "x y z. R x y  R y z  R x z"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_quicksort R it) S0 R"
unfolding iterator_to_ordered_iterator_quicksort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_wrt_quicksort_by_rel[OF lin trans_R])
done

definition iterator_to_ordered_iterator_mergesort where
  "iterator_to_ordered_iterator_mergesort R it =
   iterator_to_ordered_iterator (mergesort_by_rel R) it"

lemmas iterator_to_ordered_iterator_mergesort_code[code] =
  iterator_to_ordered_iterator_mergesort_def[unfolded iterator_to_ordered_iterator_def]

lemma iterator_to_ordered_iterator_mergesort_correct :
assumes lin : "x y. (R x y)  (R y x)"
    and trans_R: "x y z. R x y  R y z  R x z"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_mergesort R it) S0 R"
unfolding iterator_to_ordered_iterator_mergesort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_wrt_mergesort_by_rel[OF lin trans_R])
done

end


Theory Gen_Iterator

section ‹\isaheader{Iterators}›
theory Gen_Iterator
imports Refine_Monadic.Refine_Monadic Proper_Iterator
begin
  text ‹
    Iterators are realized by to-list functions followed by folding.
    A post-optimization step then replaces these constructions by
    real iterators.›

  lemma param_it_to_list[param]: "(it_to_list,it_to_list) 
    (Rs  (Ra  bool_rel)  
    (Rb  Rblist_rel  Rblist_rel)  Rclist_rel  Rd)  Rs  Rd"
    unfolding it_to_list_def[abs_def]
    by parametricity


  definition key_rel :: "('k  'k  bool)  ('k×'v)  ('k×'v)  bool"
    where "key_rel R a b  R (fst a) (fst b)"

  lemma key_rel_UNIV[simp]: "key_rel (λ_ _. True) = (λ_ _. True)"
    unfolding key_rel_def[abs_def] by auto

  subsection ‹Setup for Autoref›
  text ‹Default pattern rules for it_to_sorted_list›
  definition "set_to_sorted_list R S  it_to_sorted_list R S"
  lemma set_to_sorted_list_itype[autoref_itype]: 
    "set_to_sorted_list R ::i Iii_set i Iii_listii_nres" 
    by simp

context begin interpretation autoref_syn .
  lemma set_to_sorted_list_pat[autoref_op_pat]: 
    "it_to_sorted_list R S  OP (set_to_sorted_list R) S"
    unfolding set_to_sorted_list_def[abs_def] by auto
end

  definition "map_to_sorted_list R M 
     it_to_sorted_list (key_rel R) (map_to_set M)"
  lemma map_to_sorted_list_itype[autoref_itype]:
    "map_to_sorted_list R ::i Rk,Rvii_map i Rk,Rvii_prodii_listii_nres"
    by simp

context begin interpretation autoref_syn .
  lemma map_to_sorted_list_pat[autoref_op_pat]:
    "it_to_sorted_list (key_rel R) (map_to_set M) 
       OP (map_to_sorted_list R) M"
    "it_to_sorted_list (λ_ _. True) (map_to_set M) 
       OP (map_to_sorted_list (λ_ _. True)) M"
    unfolding map_to_sorted_list_def[abs_def] by auto
end

  subsection ‹Set iterators›
  (*definition "is_set_to_sorted_list_deprecated ordR Rk Rs tsl ≡ ∀s s'.
    (s,s')∈⟨Rk⟩Rs ⟶ 
      (RETURN (tsl s),it_to_sorted_list ordR s')∈⟨⟨Rk⟩list_rel⟩nres_rel"
    *)

  definition "is_set_to_sorted_list ordR Rk Rs tsl  s s'.
    (s,s')RkRs 
       ( l'. (tsl s,l')Rklist_rel 
             RETURN l'  it_to_sorted_list ordR s')"

  definition "is_set_to_list  is_set_to_sorted_list (λ_ _. True)"


  lemma is_set_to_sorted_listE:
    assumes "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes "(s,s')RkRs"
    obtains l' where "(tsl s,l')Rklist_rel" 
    and "RETURN l'  it_to_sorted_list ordR s'"
    using assms unfolding is_set_to_sorted_list_def by blast

  (* TODO: Move *)
  lemma it_to_sorted_list_weaken: 
    "RR'  it_to_sorted_list R s  it_to_sorted_list R' s"
    unfolding it_to_sorted_list_def
    by (auto intro!: sorted_wrt_mono_rel[where P=R])

  lemma set_to_list_by_set_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "is_set_to_list Rk Rs tsl"
    using assms
    unfolding is_set_to_list_def is_set_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    by blast


  definition "det_fold_set R c f σ result  
    l. distinct l  sorted_wrt R l  foldli l c f σ = result (set l)"

  lemma det_fold_setI[intro?]:
    assumes "l. distinct l; sorted_wrt R l 
       foldli l c f σ = result (set l)"
    shows "det_fold_set R c f σ result"
    using assms unfolding det_fold_set_def by auto

  text ‹Template lemma for generic algorithm using set iterator›
  lemma det_fold_sorted_set:
    assumes 1: "det_fold_set ordR c' f' σ' result"
    assumes 2: "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes SREF[param]: "(s,s')RkRs"
    assumes [param]:  "(c,c')Id"
    assumes [param]: "(f,f')Rk    "
    assumes [param]: "(σ,σ')"
    shows "(foldli (tsl s) c f σ, result s')  "
  proof -
    obtain tsl' where
      [param]: "(tsl s,tsl')  Rklist_rel" 
      and IT: "RETURN tsl'  it_to_sorted_list ordR s'"
      using 2 SREF
      by (rule is_set_to_sorted_listE)
    
    have "(foldli (tsl s) c f σ, foldli tsl' c' f' σ')  "
      by parametricity
    also have "foldli tsl' c' f' σ' = result s'"
      using 1 IT 
      unfolding det_fold_set_def it_to_sorted_list_def
      by simp
    finally show ?thesis .
  qed

  lemma det_fold_set:
    assumes "det_fold_set (λ_ _. True) c' f' σ' result"
    assumes "is_set_to_list Rk Rs tsl"
    assumes "(s,s')RkRs"
    assumes "(c,c')Id"
    assumes "(f,f')Rk    "
    assumes "(σ,σ')"
    shows "(foldli (tsl s) c f σ, result s')  "
    using assms
    unfolding  is_set_to_list_def
    by (rule det_fold_sorted_set)

  subsection ‹Map iterators›

  text ‹Build relation on keys›
  
  (*definition "is_map_to_sorted_list_deprecated ordR Rk Rv Rm tsl ≡ ∀m m'.
    (m,m')∈⟨Rk,Rv⟩Rm ⟶ 
      (RETURN (tsl m),it_to_sorted_list (key_rel ordR) (map_to_set m'))
      ∈⟨⟨⟨Rk,Rv⟩prod_rel⟩list_rel⟩nres_rel"*)

  definition "is_map_to_sorted_list ordR Rk Rv Rm tsl  m m'.
    (m,m')Rk,RvRm  (
      l'. (tsl m,l')Rk,Rvprod_rellist_rel
         RETURN l'  it_to_sorted_list (key_rel ordR) (map_to_set m'))"

  definition "is_map_to_list Rk Rv Rm tsl 
     is_map_to_sorted_list (λ_ _. True) Rk Rv Rm tsl"

  lemma is_map_to_sorted_listE:
    assumes "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes "(m,m')Rk,RvRm"
    obtains l' where "(tsl m,l')Rk,Rvprod_rellist_rel" 
    and "RETURN l'  it_to_sorted_list (key_rel ordR) (map_to_set m')"
    using assms unfolding is_map_to_sorted_list_def by blast

  lemma map_to_list_by_map_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Rv Rm tsl)"
    shows "is_map_to_list Rk Rv Rm tsl"
    using assms
    unfolding is_map_to_list_def is_map_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    unfolding key_rel_def[abs_def]
    by blast

  definition "det_fold_map R c f σ result  
    l. distinct (map fst l)  sorted_wrt (key_rel R) l 
       foldli l c f σ = result (map_of l)"

  lemma det_fold_mapI[intro?]:
    assumes "l. distinct (map fst l); sorted_wrt (key_rel R) l 
       foldli l c f σ = result (map_of l)"
    shows "det_fold_map R c f σ result"
    using assms unfolding det_fold_map_def by auto

  lemma det_fold_map_aux:
    assumes 1: "distinct (map fst l); sorted_wrt (key_rel R) l 
       foldli l c f σ = result (map_of l)"
    assumes 2: "RETURN l  it_to_sorted_list (key_rel R) (map_to_set m)"
    shows "foldli l c f σ = result m"
  proof -
    from 2 have "distinct l" and "set l = map_to_set m" 
      and SORTED: "sorted_wrt (key_rel R) l"
      unfolding it_to_sorted_list_def by simp_all
    hence "(k,v)set l. (k',v')set l. k=k'  v=v'"
      apply simp
      unfolding map_to_set_def
      apply auto
      done
    with ‹distinct l have DF: "distinct (map fst l)"
      apply (induct l)
      apply simp
      apply force
      done
    with ‹set l = map_to_set m have [simp]: "m = map_of l"
      by (metis map_of_map_to_set)
      
    from 1[OF DF SORTED] show ?thesis by simp
  qed
    
  text ‹Template lemma for generic algorithm using map iterator›
  lemma det_fold_sorted_map:
    assumes 1: "det_fold_map ordR c' f' σ' result"
    assumes 2: "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes MREF[param]: "(m,m')Rk,RvRm"
    assumes [param]:  "(c,c')Id"
    assumes [param]: "(f,f')Rk,Rvprod_rel    "
    assumes [param]: "(σ,σ')"
    shows "(foldli (tsl m) c f σ, result m')  "
  proof -
    obtain tsl' where
      [param]: "(tsl m,tsl')  Rk,Rvprod_rellist_rel" 
      and IT: "RETURN tsl'  it_to_sorted_list (key_rel ordR) (map_to_set m')"
      using 2 MREF by (rule is_map_to_sorted_listE)
    
    have "(foldli (tsl m) c f σ, foldli tsl' c' f' σ')  "
      by parametricity
    also have "foldli tsl' c' f' σ' = result m'"
      using det_fold_map_aux[of tsl' ordR c' f' σ' result] 1 IT
      unfolding det_fold_map_def
      by clarsimp
    finally show ?thesis .
  qed

  lemma det_fold_map:
    assumes "det_fold_map (λ_ _. True) c' f' σ' result"
    assumes "is_map_to_list Rk Rv Rm tsl"
    assumes "(m,m')Rk,RvRm"
    assumes "(c,c')Id"
    assumes "(f,f')Rk,Rvprod_rel    "
    assumes "(σ,σ')"
    shows "(foldli (tsl m) c f σ, result m')  "
    using assms
    unfolding is_map_to_list_def
    by (rule det_fold_sorted_map)

lemma set_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes TSL: "SIDE_GEN_ALGO (is_set_to_sorted_list R Rk Rs tsl)"
  shows "(λs. RETURN (tsl s), set_to_sorted_list R) 
     RkRs  Rklist_relnres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')RkRs"
  with TSL obtain l' where 
    R1: "(tsl s, l')  Rklist_rel" 
      and R2: "RETURN l'  set_to_sorted_list R s'"
    unfolding is_set_to_sorted_list_def set_to_sorted_list_def autoref_tag_defs
    by blast
  
  have "RETURN (tsl s)  (Rklist_rel) (RETURN l')"
    by (rule RETURN_refine) fact
  also note R2
  finally show "RETURN (tsl s)   (Rklist_rel) (set_to_sorted_list R s')" .
qed

lemma set_to_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 10)"
  assumes TSL: "SIDE_GEN_ALGO (is_set_to_list Rk Rs tsl)"
  shows "(λs. RETURN (tsl s), set_to_sorted_list (λ_ _. True)) 
     RkRs  Rklist_relnres_rel"
  using assms(2-) unfolding is_set_to_list_def
  by (rule set_to_sorted_list_by_tsl[OF PRIO_TAGI])

lemma map_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_sorted_list R Rk Rv Rs tsl)"
  shows "(λs. RETURN (tsl s), map_to_sorted_list R) 
     Rk,RvRs  Rk,Rvprod_rellist_relnres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')Rk,RvRs"
  with TSL obtain l' where 
    R1: "(tsl s, l')  Rk,Rvprod_rellist_rel" 
      and R2: "RETURN l'  map_to_sorted_list R s'"
    unfolding is_map_to_sorted_list_def map_to_sorted_list_def autoref_tag_defs
    by blast
  
  have "RETURN (tsl s)  (Rk,Rvprod_rellist_rel) (RETURN l')"
    apply (rule RETURN_refine)
    by fact
  also note R2
  finally show 
    "RETURN (tsl s)   (Rk,Rvprod_rellist_rel) (map_to_sorted_list R s')" .
qed

lemma map_to_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 10)"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs tsl)"
  shows "(λs. RETURN (tsl s), map_to_sorted_list (λ_ _. True)) 
     Rk,RvRs  Rk,Rvprod_rellist_relnres_rel"
  using assms(2-) unfolding is_map_to_list_def
  by (rule map_to_sorted_list_by_tsl[OF PRIO_TAGI])


(*lemma dres_it_FOREACH_it_simp[iterator_simps]: 
  "dres_it_FOREACH (λs. dRETURN (i s)) s c f σ 
    = foldli (i s) (case_dres False False c) (λx s. s ⤜ f x) (dRETURN σ)"
  unfolding dres_it_FOREACH_def
  by simp
*)

text ‹
  TODO/FIXME: 
    * Integrate mono-prover properly into solver-infrastructure,
        i.e. tag a mono-goal.
    * Tag iterators, such that, for the mono-prover, we can just convert
        a proper iterator back to its foldli-equivalent!
›
lemma proper_it_mono_dres_pair:
  assumes PR: "proper_it' it it'"
  assumes A: "k v x. f k v x  f' k v x"
  shows "
    it' s (case_dres False False c) (λ(k,v) s. s  f k v) σ
     it' s (case_dres False False c) (λ(k,v) s. s  f' k v) σ" (is "?a  ?b")
proof -
  from proper_itE[OF PR[THEN proper_it'D]] obtain l where 
    A_FMT: 
      "?a = foldli l (case_dres False False c) (λ(k,v) s. s  f k v) σ" 
        (is "_ = ?a'")
    and B_FMT: 
      "?b = foldli l (case_dres False False c) (λ(k,v) s. s  f' k v) σ" 
        (is "_ = ?b'")
    by metis
  
  from A have A': "kv x. case_prod f kv x  case_prod f' kv x"
    by auto

  note A_FMT
  also have 
    "?a' = foldli l (case_dres False False c) (λkv s. s  case_prod f kv) σ"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note foldli_mono_dres[OF A']
  also have 
    "foldli l (case_dres False False c) (λkv s. s  case_prod f' kv) σ = ?b'"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note B_FMT[symmetric]
  finally show ?thesis .
qed

lemma proper_it_mono_dres_pair_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "k v x. flat_ge (f k v x) (f' k v x)"
  shows "
    flat_ge (it' s (case_dres False False c) (λ(k,v) s. s  f k v) σ)
      (it' s (case_dres False False c) (λ(k,v) s. s  f' k v) σ)" 
      (is "flat_ge ?a ?b")
proof -
  from proper_itE[OF PR[THEN proper_it'D]] obtain l where 
    A_FMT: 
      "?a = foldli l (case_dres False False c) (λ(k,v) s. s  f k v) σ" 
        (is "_ = ?a'")
    and B_FMT: 
      "?b = foldli l (case_dres False False c) (λ(k,v) s. s  f' k v) σ" 
        (is "_ = ?b'")
    by metis
  
  from A have A': "kv x. flat_ge (case_prod f kv x) (case_prod f' kv x)"
    by auto

  note A_FMT
  also have 
    "?a' = foldli l (case_dres False False c) (λkv s. s  case_prod f kv) σ"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note foldli_mono_dres_flat[OF A']
  also have 
    "foldli l (case_dres False False c) (λkv s. s  case_prod f' kv) σ = ?b'"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note B_FMT[symmetric]
  finally show ?thesis .
qed

    
lemma proper_it_mono_dres:
  assumes PR: "proper_it' it it'"
  assumes A: "kv x. f kv x  f' kv x"
  shows "
    it' s (case_dres False False c) (λkv s. s  f kv) σ
     it' s (case_dres False False c) (λkv s. s  f' kv) σ"
  apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
  apply (erule_tac t="it' s" in ssubst)
  apply (rule foldli_mono_dres[OF A])
  done

lemma proper_it_mono_dres_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "kv x. flat_ge (f kv x) (f' kv x)"
  shows "
    flat_ge (it' s (case_dres False False c) (λkv s. s  f kv) σ)
      (it' s (case_dres False False c) (λkv s. s  f' kv) σ)"
  apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
  apply (erule_tac t="it' s" in ssubst)
  apply (rule foldli_mono_dres_flat[OF A])
  done

lemma pi'_dom[icf_proper_iteratorI]: "proper_it' it it' 
   proper_it' (map_iterator_dom o it) (map_iterator_dom o it')"
  apply (rule proper_it'I)
  apply (simp add: comp_def)
  apply (rule icf_proper_iteratorI)
  apply (erule proper_it'D)
  done

lemma proper_it_mono_dres_dom:
  assumes PR: "proper_it' it it'"
  assumes A: "kv x. f kv x  f' kv x"
  shows "
    (map_iterator_dom o it') s (case_dres False False c) (λkv s. s  f kv) σ
     
    (map_iterator_dom o it') s (case_dres False False c) (λkv s. s  f' kv) σ"
  
  apply (rule proper_it_mono_dres)
  apply (rule icf_proper_iteratorI)
  by fact+

lemma proper_it_mono_dres_dom_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "kv x. flat_ge (f kv x) (f' kv x)"
  shows "flat_ge 
    ((map_iterator_dom o it') s (case_dres False False c) (λkv s. s  f kv) σ)
    ((map_iterator_dom o it') s (case_dres False False c) (λkv s. s  f' kv) σ)"
  apply (rule proper_it_mono_dres_flat)
  apply (rule icf_proper_iteratorI)
  by fact+


(* TODO/FIXME: Hack! Mono-prover should be able to find proper-iterators itself
*)
lemmas proper_it_monos = 
  proper_it_mono_dres_pair proper_it_mono_dres_pair_flat
  proper_it_mono_dres proper_it_mono_dres_flat
  proper_it_mono_dres_dom proper_it_mono_dres_dom_flat

(* TODO: Conceptually, this leads to some kind of bundles: 
  Each bundle has a list of processors, that are invoked for every registered
  theorem. *)


attribute_setup "proper_it" = ‹
  Scan.succeed (Thm.declaration_attribute (fn thm => fn context => 
    let
      val mono_thms = map_filter (try (curry (RS) thm)) @{thms proper_it_monos}
      (*val mono_thms = map (fn mt => thm RS mt) @{thms proper_it_monos}*)
      val context = context 
        |> Icf_Proper_Iterator.add_thm thm
        |> fold Refine_Mono_Prover.add_mono_thm mono_thms
    in
      context
    end
  ))
  "Proper iterator declaration"

end

Theory Idx_Iterator

section ‹\isaheader{Iterator by get and size }›
theory Idx_Iterator
imports
  SetIterator
  Automatic_Refinement.Automatic_Refinement
begin

fun idx_iteratei_aux 
  :: "('s  nat  'a)  nat  nat  's  (bool)  ('a   )    "
where
  "idx_iteratei_aux get sz i l c f σ = (
    if i=0  ¬ c σ then σ
    else idx_iteratei_aux get sz (i - 1) l c f (f (get l (sz-i)) σ)
  )"

declare idx_iteratei_aux.simps[simp del]

lemma idx_iteratei_aux_simps[simp]:
  "i=0  idx_iteratei_aux get sz i l c f σ = σ"
  "¬c σ  idx_iteratei_aux get sz i l c f σ = σ"
  "i0; c σ  idx_iteratei_aux get sz i l c f σ = idx_iteratei_aux get sz (i - 1) l c f (f (get l (sz-i)) σ)"
  apply -
  apply (subst idx_iteratei_aux.simps, simp)+
  done

definition "idx_iteratei get sz l c f σ == idx_iteratei_aux get (sz l) (sz l) l c f σ"

lemma idx_iteratei_eq_foldli:
  assumes sz: "(sz, length)  arel  nat_rel"
  assumes get: "(get, (!))  arel  nat_rel  Id"
  assumes "(s,s')  arel"
  shows "(idx_iteratei get sz s, foldli s')  Id" 
proof-
  have size_correct: "s s'. (s,s')  arel  sz s = length s'"
      using sz[param_fo] by simp
  have get_correct: "s s' n. (s,s')  arel  get s n = s' ! n"
      using get[param_fo] by simp
  {
    fix n l
    assume A: "Suc n  length l"
    hence B: "length l - Suc n < length l" by simp
    from A have [simp]: "Suc (length l - Suc n) = length l - n" by simp
    from Cons_nth_drop_Suc[OF B, simplified] have 
      "drop (length l - Suc n) l = l!(length l - Suc n)#drop (length l - n) l" 
      by simp
  } note drop_aux=this

  {
    fix s s' c f σ i
    assume "(s,s')  arel" "isz s"
    hence "idx_iteratei_aux get (sz s) i s c f σ = foldli (drop (sz s - i) s') c f σ"
    proof (induct i arbitrary: σ)
      case 0 with size_correct[of s] show ?case by simp
    next
      case (Suc n)
      note S = Suc.prems(1)
      show ?case proof (cases "c σ")
        case False thus ?thesis by simp
      next
        case [simp, intro!]: True
        show ?thesis using Suc
            by (simp add: size_correct[OF S] get_correct[OF S] drop_aux)
      qed
    qed
  } note aux=this

  show ?thesis
    unfolding idx_iteratei_def[abs_def]
    by (simp, intro ext, simp add: aux[OF (s,s')  arel])
qed


text ‹Misc.›

lemma idx_iteratei_aux_nth_conv_foldli_drop:
  fixes xs :: "'b list"
  assumes "i  length xs"
  shows "idx_iteratei_aux (!) (length xs) i xs c f σ = foldli (drop (length xs - i) xs) c f σ"
using assms
proof(induct get"(!) :: 'b list  nat  'b" sz"length xs" i xs c f σ rule: idx_iteratei_aux.induct)
  case (1 i l c f σ)
  show ?case
  proof(cases "i = 0  ¬ c σ")
    case True thus ?thesis
      by(subst idx_iteratei_aux.simps)(auto)
  next
    case False
    hence i: "i > 0" and c: "c σ" by auto
    hence "idx_iteratei_aux (!) (length l) i l c f σ = idx_iteratei_aux (!) (length l) (i - 1) l c f (f (l ! (length l - i)) σ)"
      by(subst idx_iteratei_aux.simps) simp
    also have " = foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) σ)"
      using i  length l i c by -(rule 1, auto)
    also from i  length l i
    have "drop (length l - i) l = (l ! (length l - i)) # drop (length l - (i - 1)) l"
      apply (subst Cons_nth_drop_Suc[symmetric])
      apply simp_all
      done
    hence "foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) σ) = foldli (drop (length l - i) l) c f σ"
      using c by simp
    finally show ?thesis .
  qed
qed

lemma idx_iteratei_nth_length_conv_foldli: "idx_iteratei nth length = foldli"
by(rule ext)+(simp add: idx_iteratei_def idx_iteratei_aux_nth_conv_foldli_drop)
end

Theory Iterator

theory Iterator
imports 
  It_to_It 
  SetIteratorOperations 
  SetIteratorGA 
  Proper_Iterator
  Gen_Iterator
  Idx_Iterator
begin

  text ‹Folding over a list created by a proper iterator can be replaced
    by a single iteration›
  lemma proper_it_to_list_opt[refine_transfer_post_subst]:
    assumes PR: "proper_it' it it'"
    shows "foldli o it_to_list it  it'"
  proof (rule eq_reflection, intro ext)
    fix s c f σ
    
    obtain l where "it s = foldli l" and "it' s = foldli l"
      by (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
    thus "(foldli o it_to_list it) s c f σ = it' s c f σ"
      by (simp add: comp_def it_to_list_def)
  qed

  lemma iterator_cnv_to_comp[refine_transfer_post_simp]:
    "foldli (it_to_list it x) = (foldli o it_to_list it) x"
    by auto

  declare idx_iteratei_eq_foldli[autoref_rules]

end

Theory RBT_add

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Additions to RB-Trees}›
theory RBT_add
imports 
  "HOL-Library.RBT_Impl" 
  "../Iterator/Iterator"
begin
text_raw ‹\label{thy:RBT_add}›

lemma tlt_trans: "l  u; uv  l  v"
  by (induct l) auto

lemma trt_trans: " uv; v«|r   u«|r"
  by (induct r) auto

lemmas tlt_trans' = tlt_trans[OF _ less_imp_le]
lemmas trt_trans' = trt_trans[OF less_imp_le]

primrec rm_iterateoi 
  :: "('k,'v) RBT_Impl.rbt  ('k × 'v, ) set_iterator"
  where
  "rm_iterateoi RBT_Impl.Empty c f σ = σ" |
  "rm_iterateoi (RBT_Impl.Branch col l k v r) c f σ = (
    if (c σ) then
      let σ' = rm_iterateoi l c f σ in
        if (c σ') then
          rm_iterateoi r c f (f (k, v) σ')
        else σ'
    else 
      σ
  )"

lemma rm_iterateoi_abort :
  "¬(c σ)  rm_iterateoi t c f σ = σ"
by (cases t) auto

lemma rm_iterateoi_alt_def :
  "rm_iterateoi RBT_Impl.Empty = set_iterator_emp"
  "rm_iterateoi (RBT_Impl.Branch col l k v r) = 
   set_iterator_union (rm_iterateoi l)
     (set_iterator_union (set_iterator_sng (k, v)) (rm_iterateoi r))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_iterateoi_abort
                  set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_iterateoi.simps[simp del]


primrec rm_reverse_iterateoi 
  :: "('k,'v) RBT_Impl.rbt  ('k × 'v, ) set_iterator"
  where
  "rm_reverse_iterateoi RBT_Impl.Empty c f σ = σ" |
  "rm_reverse_iterateoi (Branch col l k v r) c f σ = (
    if (c σ) then
      let σ' = rm_reverse_iterateoi r c f σ in
        if (c σ') then
          rm_reverse_iterateoi l c f (f (k, v) σ')
        else σ'
    else 
      σ
  )"

lemma rm_reverse_iterateoi_abort :
  "¬(c σ)  rm_reverse_iterateoi t c f σ = σ"
by (cases t) auto

lemma rm_reverse_iterateoi_alt_def :
  "rm_reverse_iterateoi RBT_Impl.Empty = set_iterator_emp"
  "rm_reverse_iterateoi (RBT_Impl.Branch col l k v r) = 
   set_iterator_union (rm_reverse_iterateoi r)
     (set_iterator_union (set_iterator_sng (k, v)) (rm_reverse_iterateoi l))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_reverse_iterateoi_abort
                  set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_reverse_iterateoi.simps[simp del]

(*
lemma finite_dom_lookup [simp, intro!]: "finite (dom (RBT.lookup t))"
by(simp add: RBT.lookup_def)


instantiation rbt :: ("{equal, linorder}", equal) equal begin

definition "equal_class.equal (r :: ('a, 'b) rbt) r' == RBT.impl_of r = RBT.impl_of r'"

instance
proof
qed (simp add: equal_rbt_def RBT.impl_of_inject)

end
*)

lemma (in linorder) map_to_set_lookup_entries: 
   "rbt_sorted t  map_to_set (rbt_lookup t) = set (RBT_Impl.entries t)"
  using map_of_entries[symmetric,of t]
  by (simp add: distinct_entries map_to_set_map_of)

lemma (in linorder) rm_iterateoi_correct:
  fixes t::"('a, 'v) RBT_Impl.rbt"
  assumes is_sort: "rbt_sorted t"
  defines "it  
  RBT_add.rm_iterateoi::(('a, 'v) RBT_Impl.rbt  ('a × 'v, ) set_iterator)"
  shows "map_iterator_linord (it t) (rbt_lookup t)"
  using is_sort
proof (induct t)
  case Empty
  show ?case unfolding it_def 
    by (simp add: rm_iterateoi_alt_def 
      map_iterator_linord_emp_correct rbt_lookup_Empty)
next
  case (Branch c l k v r)
  note is_sort_t = Branch(3)

  from Branch(1) is_sort_t have 
    l_it: "map_iterator_linord (it l) (rbt_lookup l)" by simp
  from Branch(2) is_sort_t have 
    r_it: "map_iterator_linord (it r) (rbt_lookup r)" by simp
  note kv_it = map_iterator_linord_sng_correct[of k v]

  have kv_r_it : "set_iterator_map_linord
     (set_iterator_union (set_iterator_sng (k, v)) (it r))
     (map_to_set [k  v]  map_to_set (rbt_lookup r))"
  proof (rule map_iterator_linord_union_correct [OF kv_it r_it])
    fix kv kv'
    assume pre: "kv  map_to_set [k  v]" "kv'  map_to_set (rbt_lookup r)"
    obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule prod.exhaust)
 
    from pre is_sort_t show "fst kv < fst kv'" 
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      apply (metis entry_in_tree_keys rbt_greater_prop)
      done
  qed

  have l_kv_r_it : "set_iterator_map_linord (it (Branch c l k v r))
     (map_to_set (rbt_lookup l) 
       (map_to_set [k  v]  map_to_set (rbt_lookup r)))"
    unfolding it_def rm_iterateoi_alt_def
    unfolding it_def[symmetric]
  proof (rule map_iterator_linord_union_correct [OF l_it kv_r_it])
    fix kv1 kv2
    assume pre: "kv1  map_to_set (rbt_lookup l)" 
                "kv2  map_to_set [k  v]  map_to_set (rbt_lookup r)" 

    obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule prod.exhaust)
    obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule prod.exhaust)

    from pre is_sort_t show "fst kv1 < fst kv2" 
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      by (metis (lifting) map_of_entries neqE option.simps(3) 
        ord.rbt_lookup_rbt_greater ord.rbt_lookup_rbt_less rbt_greater_trans 
        rbt_less_trans weak_map_of_SomeI)
  qed
  
  from is_sort_t
  have map_eq: "map_to_set (rbt_lookup l) 
     (map_to_set [k  v]  map_to_set (rbt_lookup r)) =
        map_to_set (rbt_lookup (Branch c l k v r))" 
    by (simp add: set_eq_iff map_to_set_lookup_entries)
  
  from l_kv_r_it[unfolded map_eq]
  show ?case .
qed

lemma (in linorder) rm_reverse_iterateoi_correct:
  fixes t::"('a, 'v) RBT_Impl.rbt"
  assumes is_sort: "rbt_sorted t"
  defines "it  RBT_add.rm_reverse_iterateoi
    ::(('a, 'v) RBT_Impl.rbt  ('a × 'v, ) set_iterator)"
  shows "map_iterator_rev_linord (it t) (rbt_lookup t)"
  using is_sort
proof (induct t)
  case Empty
  show ?case unfolding it_def 
    by (simp add: rm_reverse_iterateoi_alt_def 
      map_iterator_rev_linord_emp_correct rbt_lookup_Empty)
next
  case (Branch c l k v r)
  note is_sort_t = Branch(3)

  from Branch(1) is_sort_t have 
    l_it: "map_iterator_rev_linord (it l) (rbt_lookup l)" by simp
  from Branch(2) is_sort_t have 
    r_it: "map_iterator_rev_linord (it r) (rbt_lookup r)" by simp
  note kv_it = map_iterator_rev_linord_sng_correct[of k v]

  have kv_l_it : "set_iterator_map_rev_linord
     (set_iterator_union (set_iterator_sng (k, v)) (it l))
     (map_to_set [k  v]  map_to_set (rbt_lookup l))"
  proof (rule map_iterator_rev_linord_union_correct [OF kv_it l_it])
    fix kv kv'
    assume pre: "kv  map_to_set [k  v]" "kv'  map_to_set (rbt_lookup l)"
    obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule prod.exhaust)
 
    from pre is_sort_t show "fst kv > fst kv'" 
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      apply (metis entry_in_tree_keys rbt_less_prop)
   done
  qed

  have r_kv_l_it : "set_iterator_map_rev_linord (it (Branch c l k v r))
     (map_to_set (rbt_lookup r) 
       (map_to_set [k  v]  map_to_set (rbt_lookup l)))"
    unfolding it_def rm_reverse_iterateoi_alt_def
    unfolding it_def[symmetric]
  proof (rule map_iterator_rev_linord_union_correct [OF r_it kv_l_it])
    fix kv1 kv2
    assume pre: "kv1  map_to_set (rbt_lookup r)" 
                "kv2  map_to_set [k  v]  map_to_set (rbt_lookup l)" 

    obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule prod.exhaust)
    obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule prod.exhaust)

    from pre is_sort_t show "fst kv1 > fst kv2" 
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      by (metis (mono_tags) entry_in_tree_keys neq_iff option.simps(3) 
        ord.rbt_greater_prop ord.rbt_lookup_rbt_less rbt_less_trans 
        rbt_lookup_in_tree)
  qed
  
  from is_sort_t
  have map_eq: "map_to_set (rbt_lookup r) 
     (map_to_set [k  v]  map_to_set (rbt_lookup l)) =
        map_to_set (rbt_lookup (Branch c l k v r))" 
    by (auto simp add: set_eq_iff map_to_set_lookup_entries)

  from r_kv_l_it[unfolded map_eq]
  show ?case .
qed

lemma pi_rm[icf_proper_iteratorI]: 
  "proper_it (RBT_add.rm_iterateoi t) (RBT_add.rm_iterateoi t)"
  by (induct t) (simp_all add: rm_iterateoi_alt_def icf_proper_iteratorI)

lemma pi_rm_rev[icf_proper_iteratorI]: 
  "proper_it (RBT_add.rm_reverse_iterateoi t) (RBT_add.rm_reverse_iterateoi t)"
  by (induct t) (simp_all add: rm_reverse_iterateoi_alt_def 
    icf_proper_iteratorI)

primrec bheight_aux :: "('a,'b) RBT_Impl.rbt  nat  nat"
where
  "acc. bheight_aux RBT_Impl.Empty acc = acc"
| "acc. bheight_aux (RBT_Impl.Branch c lt k v rt) acc = 
     bheight_aux lt (case c of RBT_Impl.B  Suc acc | RBT_Impl.R  acc)"

lemma bheight_aux_eq: "bheight_aux t a = bheight t + a"
  by (induct t arbitrary: a) (auto split: RBT_Impl.color.split)

definition [code_unfold]: "rbt_bheight t  bheight_aux t 0"
lemma "rbt_bheight t = bheight t"
  unfolding rbt_bheight_def by (simp add: bheight_aux_eq)

(*definition "black_height t ≡ rbt_bheight (RBT.impl_of t)"*)

end

Theory Dlist_add

section ‹\isaheader{Additions to Distinct Lists}›
theory Dlist_add 
  imports 
  "HOL-Library.Dlist" 
  Automatic_Refinement.Misc
  "../Iterator/SetIteratorOperations" 
begin

primrec dlist_remove1' :: "'a  'a list  'a list  'a list"
where
  "dlist_remove1' x z [] = z"
| "dlist_remove1' x z (y # ys) 
  = (if x = y then z @ ys else dlist_remove1' x (y # z) ys)"

definition dlist_remove' :: "'a  'a dlist  'a dlist"
where "dlist_remove' a xs = Dlist (dlist_remove1' a [] (list_of_dlist xs))"

lemma distinct_remove1': "distinct (xs @ ys)  
  distinct (dlist_remove1' x xs ys)"
  by(induct ys arbitrary: xs) simp_all

lemma set_dlist_remove1': "distinct ys  
  set (dlist_remove1' x xs ys) = set xs  (set ys - {x})"
  by(induct ys arbitrary: xs) auto

lemma list_of_dlist_remove' [simp, code abstract]:
  "list_of_dlist (dlist_remove' a xs) = dlist_remove1' a [] (list_of_dlist xs)"
by(simp add: dlist_remove'_def distinct_remove1')

lemma dlist_remove'_correct: 
  "y  set (list_of_dlist (dlist_remove' x xs)) 
   (if x = y then False else y  set (list_of_dlist xs))"
  by(simp add: dlist_remove'_def 
    Dlist.member_def List.member_def set_dlist_remove1')

definition dlist_iteratei :: "'a dlist  ('a, 'b) set_iterator"
  where "dlist_iteratei xs = foldli (list_of_dlist xs)"

lemma dlist_iteratei_correct:
  "set_iterator (dlist_iteratei xs) (set (list_of_dlist xs))"
using distinct_list_of_dlist[of xs] 
      set_iterator_foldli_correct[of "list_of_dlist xs"]
unfolding Dlist.member_def List.member_def dlist_iteratei_def
by simp

lemma dlist_member_empty: "(set (list_of_dlist Dlist.empty)) = {}"
  by(simp add: Dlist.empty_def)

lemma dlist_member_insert [simp]: "set (list_of_dlist (Dlist.insert x xs)) 
  = insert x (set (list_of_dlist xs))"
  by(simp add: Dlist.insert_def Dlist.member_def )

lemma dlist_finite_member [simp, intro!]: "finite (set (list_of_dlist xs))"
by(simp add: member_def )

end

Theory Assoc_List

section ‹\isaheader{The type of associative lists}›
theory Assoc_List 
  imports 
  "HOL-Library.AList" 
  "../Iterator/SetIteratorOperations"
begin

subsection ‹Type ('a, 'b) assoc_list›

typedef ('k, 'v) assoc_list = "{xs :: ('k × 'v) list. distinct (map fst xs)}"
morphisms impl_of Assoc_List
by(rule exI[where x="[]"]) simp

lemma assoc_list_ext: "impl_of xs = impl_of ys  xs = ys"
by(simp add: impl_of_inject)

lemma expand_assoc_list_eq: "xs = ys  impl_of xs = impl_of ys"
by(simp add: impl_of_inject)

lemma impl_of_distinct [simp, intro]: "distinct (map fst (impl_of al))"
using impl_of[of al] by simp

lemma impl_of_distinct_full [simp, intro]: "distinct (impl_of al)"
using impl_of_distinct[of al] 
unfolding distinct_map by simp

lemma Assoc_List_impl_of [code abstype]: "Assoc_List (impl_of al) = al"
by(rule impl_of_inverse)

subsection ‹Primitive operations›

definition empty :: "('k, 'v) assoc_list"
where [code del]: "empty = Assoc_List []"

definition lookup :: "('k, 'v) assoc_list  'k  'v option"
where [code]: "lookup al = map_of (impl_of al)" 

definition update_with :: "'v  'k  ('v  'v)  ('k, 'v) assoc_list  ('k, 'v) assoc_list"
where [code del]: "update_with v k f al = Assoc_List (AList.update_with_aux v k f (impl_of al))"

definition delete :: "'k  ('k, 'v) assoc_list  ('k, 'v) assoc_list"
where [code del]: "delete k al = Assoc_List (AList.delete_aux k (impl_of al))"

definition iteratei :: "('k, 'v) assoc_list  ('sbool)  ('k × 'v  's  's)  's  's" 
where [code]: "iteratei al c f = foldli (impl_of al) c f"

lemma impl_of_empty [code abstract]: "impl_of empty = []"
by(simp add: empty_def Assoc_List_inverse)

lemma impl_of_update_with [code abstract]:
  "impl_of (update_with v k f al) = AList.update_with_aux v k f (impl_of al)"
by(simp add: update_with_def Assoc_List_inverse)

lemma impl_of_delete [code abstract]:
  "impl_of (delete k al) = AList.delete_aux k (impl_of al)"
by(simp add: delete_def Assoc_List_inverse)

subsection ‹Abstract operation properties›

lemma lookup_empty [simp]: "lookup empty k = None"
by(simp add: empty_def lookup_def Assoc_List_inverse)

lemma lookup_empty': "lookup empty = Map.empty"
by(rule ext) simp

lemma lookup_update_with [simp]: 
  "lookup (update_with v k f al) = (lookup al)(k  case lookup al k of None  f v | Some v  f v)"
by(simp add: lookup_def update_with_def Assoc_List_inverse map_of_update_with_aux)

lemma lookup_delete [simp]: "lookup (delete k al) = (lookup al)(k := None)"
by(simp add: lookup_def delete_def Assoc_List_inverse distinct_delete map_of_delete_aux')

lemma finite_dom_lookup [simp, intro!]: "finite (dom (lookup m))"
by(simp add: lookup_def finite_dom_map_of)

lemma iteratei_correct:
  "map_iterator (iteratei m) (lookup m)"
unfolding iteratei_def[abs_def] lookup_def map_to_set_def
by (simp add: set_iterator_foldli_correct)


subsection ‹Derived operations›

definition update :: "'key  'val  ('key, 'val) assoc_list  ('key, 'val) assoc_list"
where "update k v = update_with v k (λ_. v)"

definition set :: "('key, 'val) assoc_list  ('key × 'val) set"
where "set al = List.set (impl_of al)"


lemma lookup_update [simp]: "lookup (update k v al) = (lookup al)(k  v)"
by(simp add: update_def split: option.split)

lemma set_empty [simp]: "set empty = {}"
by(simp add: set_def empty_def Assoc_List_inverse)

lemma set_update_with:
  "set (update_with v k f al) = 
  (set al - {k} × UNIV  {(k, f (case lookup al k of None  v | Some v  v))})"
by(simp add: set_def update_with_def Assoc_List_inverse set_update_with_aux lookup_def)

lemma set_update: "set (update k v al) = (set al - {k} × UNIV  {(k, v)})"
by(simp add: update_def set_update_with)

lemma set_delete: "set (delete k al) = set al - {k} × UNIV"
by(simp add: set_def delete_def Assoc_List_inverse set_delete_aux)

subsection ‹Type classes›

instantiation assoc_list :: (equal, equal) equal begin

definition "equal_class.equal (al :: ('a, 'b) assoc_list) al' == impl_of al = impl_of al'"

instance
proof
qed (simp add: equal_assoc_list_def impl_of_inject)

end

instantiation assoc_list :: (type, type) size begin

definition "size (al :: ('a, 'b) assoc_list) = length (impl_of al)"

instance ..
end

hide_const (open) impl_of empty lookup update_with set update delete iteratei 

subsection @{const map_ran}

text @{term map_ran} with more general type - lemmas replicated from AList in HOL/Library›

hide_const (open) map_ran

primrec
  map_ran :: "('key  'val  'val')  ('key × 'val) list  ('key × 'val') list"
where
    "map_ran f [] = []"
  | "map_ran f (p#ps) = (fst p, f (fst p) (snd p)) # map_ran f ps"

lemma map_ran_conv: "map_of (map_ran f al) k = map_option (f k) (map_of al k)"
  by (induct al) auto

lemma dom_map_ran: "fst ` set (map_ran f al) = fst ` set al"
  by (induct al) auto

lemma distinct_map_ran: "distinct (map fst al)  distinct (map fst (map_ran f al))"
  by (induct al) (auto simp add: dom_map_ran)

lemma map_ran_filter: "map_ran f [(a, _)ps. fst p  a] = [(a, _)map_ran f ps. fst p  a]"
  by (induct ps) auto

lemma clearjunk_map_ran: "AList.clearjunk (map_ran f al) 
  = map_ran f (AList.clearjunk al)"
  by (induct al rule: clearjunk.induct) (simp_all add: AList.delete_eq map_ran_filter)

text ‹new lemmas and definitions›

lemma map_ran_cong [fundef_cong]:
  " al = al'; k v. (k, v)  set al  f k v = g k v   map_ran f al = map_ran g al'"
by hypsubst_thin (induct al', auto)

lemma size_list_delete: "size_list f (AList.delete a al)  size_list f al"
by(induct al) simp_all

lemma size_list_clearjunk: "size_list f (AList.clearjunk al)  size_list f al"
by(induct al)(auto simp add: clearjunk_delete intro: le_trans[OF size_list_delete])

lemma set_delete_conv: "set (AList.delete a al) = set al - ({a} × UNIV)"
proof(induct al)
  case (Cons kv al)
  thus ?case by(cases kv) auto
qed simp

lemma set_clearjunk_subset: "set (AList.clearjunk al)  set al"
by(induct al)(auto simp add: clearjunk_delete set_delete_conv)

lemma map_ran_conv_map:
  "map_ran f xs = map (λ(k, v). (k, f k v)) xs"
by(induct xs) auto

lemma card_dom_map_of: "distinct (map fst al)  card (dom (map_of al)) = length al"
by(induct al)(auto simp add: card_insert_if finite_dom_map_of dom_map_of_conv_image_fst)

lemma map_of_map_inj_fst:
  assumes "inj f"
  shows "map_of (map (λ(k, v). (f k, v)) xs) (f x) = map_of xs x"
by(induct xs)(auto dest: injD[OF ‹inj f])

lemma length_map_ran [simp]: "length (map_ran f xs) = length xs"
by(induct xs) simp_all

lemma length_update: 
  "length (AList.update k v xs) 
  = (if k  fst ` set xs then length xs else Suc (length xs))"
by(induct xs) simp_all

lemma length_distinct: 
  "distinct (map fst xs)  length (AList.delete k xs) 
  = (if k  fst ` set xs then length xs - 1 else length xs)"
  by(induct xs)(auto split: if_split_asm simp add: in_set_conv_nth)

lemma finite_Assoc_List_set_image:
  assumes "finite (Assoc_List.set ` A)"
  shows "finite A"
proof -
  have "Assoc_List.set ` A = set ` Assoc_List.impl_of ` A"
    by (auto simp add: Assoc_List.set_def)
  with assms finite_set_image have "finite (Assoc_List.impl_of ` A)" by auto
  with assoc_list_ext show ?thesis by (metis inj_onI finite_imageD)
qed

end

Theory Diff_Array

section ‹Arrays with in-place updates›
theory Diff_Array imports
  Assoc_List
  Automatic_Refinement.Parametricity
  "HOL-Library.Code_Target_Numeral"
begin

datatype 'a array = Array "'a list"

subsection ‹primitive operations›

definition new_array :: "'a  nat  'a array"
where "new_array a n = Array (replicate n a)"

primrec array_length :: "'a array  nat"
where "array_length (Array a) = length a"

primrec array_get :: "'a array  nat  'a"
where "array_get (Array a) n = a ! n"

primrec array_set :: "'a array  nat  'a  'a array"
where "array_set (Array A) n a = Array (A[n := a])"

definition array_of_list :: "'a list  'a array"
where "array_of_list = Array"

  ― ‹Grows array by @{text inc} elements initialized to value @{text x}.›
primrec array_grow :: "'a array  nat  'a  'a array"
  where "array_grow (Array A) inc x = Array (A @ replicate inc x)"

  ― ‹Shrinks array to new size @{text sz}. Undefined if @{text "sz > array_length"}
primrec array_shrink :: "'a array  nat  'a array"
  where "array_shrink (Array A) sz = (
  if (sz > length A) then
    undefined
  else
    Array (take sz A)
  )"

subsection ‹Derived operations›

text ‹The following operations are total versions of
  array_get› and array_set›, which return a default
  value in case the index is out of bounds.
  They can be efficiently implemented in the target language by catching
  exceptions.
›
definition "array_get_oo x a i 
  if i<array_length a then array_get a i else x"
definition "array_set_oo f a i v 
  if i<array_length a then array_set a i v else f ()"

primrec list_of_array :: "'a array  'a list"
where "list_of_array (Array a) = a"

primrec assoc_list_of_array :: "'a array  (nat × 'a) list"
where "assoc_list_of_array (Array a) = zip [0..<length a] a"

function assoc_list_of_array_code :: "'a array  nat  (nat × 'a) list"
where [simp del]:
  "assoc_list_of_array_code a n =
  (if array_length a  n then []
   else (n, array_get a n) # assoc_list_of_array_code a (n + 1))"
by pat_completeness auto
termination assoc_list_of_array_code
by(relation "measure (λp. (array_length (fst p) - snd p))") auto

definition array_map :: "(nat  'a  'b)  'a array  'b array"
where "array_map f a = array_of_list (map (λ(i, v). f i v) (assoc_list_of_array a))"

definition array_foldr :: "(nat  'a  'b  'b)  'a array  'b  'b"
where "array_foldr f a b = foldr (λ(k, v). f k v) (assoc_list_of_array a) b"

definition array_foldl :: "(nat  'b  'a  'b)  'b  'a array  'b"
where "array_foldl f b a = foldl (λb (k, v). f k b v) b (assoc_list_of_array a)"

subsection ‹Lemmas›

lemma array_length_new_array [simp]:
  "array_length (new_array a n) = n"
by(simp add: new_array_def)

lemma array_length_array_set [simp]:
  "array_length (array_set a i e) = array_length a"
by(cases a) simp

lemma array_get_new_array [simp]:
  "i < n  array_get (new_array a n) i = a"
by(simp add: new_array_def)

lemma array_get_array_set_same [simp]:
  "n < array_length A  array_get (array_set A n a) n = a"
by(cases A) simp

lemma array_get_array_set_other:
  "n  n'  array_get (array_set A n a) n' = array_get A n'"
by(cases A) simp

lemma list_of_array_grow [simp]:
  "list_of_array (array_grow a inc x) = list_of_array a @ replicate inc x"
by (cases a) (simp)

lemma array_grow_length [simp]:
  "array_length (array_grow a inc x) = array_length a + inc"
by (cases a)(simp add: array_of_list_def)

lemma array_grow_get [simp]:
  "i < array_length a  array_get (array_grow a inc x) i = array_get a i"
  " i  array_length a;  i < array_length a + inc  array_get (array_grow a inc x) i = x"
by (cases a, simp add: nth_append)+

lemma list_of_array_shrink [simp]:
  " s  array_length a  list_of_array (array_shrink a s) = take s (list_of_array a)"
by (cases a) simp

lemma array_shrink_get [simp]:
  " i < s; s  array_length a   array_get (array_shrink a s) i = array_get a i"
by (cases a) (simp)

lemma list_of_array_id [simp]: "list_of_array (array_of_list l) = l"
by (cases l)(simp_all add: array_of_list_def)

lemma map_of_assoc_list_of_array:
  "map_of (assoc_list_of_array a) k = (if k < array_length a then Some (array_get a k) else None)"
by(cases a, cases "k < array_length a")(force simp add: set_zip)+

lemma length_assoc_list_of_array [simp]:
  "length (assoc_list_of_array a) = array_length a"
by(cases a) simp

lemma distinct_assoc_list_of_array:
  "distinct (map fst (assoc_list_of_array a))"
by(cases a)(auto)

lemma array_length_array_map [simp]:
  "array_length (array_map f a) = array_length a"
by(simp add: array_map_def array_of_list_def)

lemma array_get_array_map [simp]:
  "i < array_length a  array_get (array_map f a) i = f i (array_get a i)"
by(cases a)(simp add: array_map_def map_ran_conv_map array_of_list_def)

lemma array_foldr_foldr:
  "array_foldr (λn. f) (Array a) b = foldr f a b"
by(simp add: array_foldr_def foldr_snd_zip)

lemma assoc_list_of_array_code_induct:
  assumes IH: "n. (n < array_length a  P (Suc n))  P n"
  shows "P n"
proof -
  have "a = a  P n"
    by(rule assoc_list_of_array_code.induct[where P="λa' n. a = a'  P n"])(auto intro: IH)
  thus ?thesis by simp
qed

lemma assoc_list_of_array_code [code]:
  "assoc_list_of_array a = assoc_list_of_array_code a 0"
proof(cases a)
  case (Array A)
  { fix n
    have "zip [n..<length A] (drop n A) = assoc_list_of_array_code (Array A) n"
    proof(induct n taking: "Array A" rule: assoc_list_of_array_code_induct)
      case (1 n)
      show ?case
      proof(cases "n < array_length (Array A)")
        case False
        thus ?thesis by(simp add: assoc_list_of_array_code.simps)
      next
        case True
        hence "zip [Suc n..<length A] (drop (Suc n) A) = assoc_list_of_array_code (Array A) (Suc n)"
          by(rule 1)
        moreover from True have "n < length A" by simp
        moreover then obtain a A' where A: "drop n A = a # A'" by(cases "drop n A") auto
        moreover with n < length A have [simp]: "a = A ! n"
          by(subst append_take_drop_id[symmetric, where n=n])(simp add: nth_append min_def)
        moreover from A have "drop (Suc n) A = A'"
          by(induct A arbitrary: n)(simp_all add: drop_Cons split: nat.split_asm)
        ultimately show ?thesis by(subst upt_rec)(simp add: assoc_list_of_array_code.simps)
      qed
    qed }
  note this[of 0]
  with Array show ?thesis by simp
qed

lemma list_of_array_code [code]:
  "list_of_array a = array_foldr (λn. Cons) a []"
by(cases a)(simp add: array_foldr_foldr foldr_Cons)

lemma array_foldr_cong [fundef_cong]:
  " a = a'; b = b';
    i b. i < array_length a  f i (array_get a i) b = g i (array_get a i) b 
   array_foldr f a b = array_foldr g a' b'"
by(cases a)(auto simp add: array_foldr_def set_zip intro!: foldr_cong)

lemma array_foldl_foldl:
  "array_foldl (λn. f) b (Array a) = foldl f b a"
by(simp add: array_foldl_def foldl_snd_zip)

lemma array_map_conv_foldl_array_set:
  assumes len: "array_length A = array_length a"
  shows "array_map f a = foldl (λA (k, v). array_set A k (f k v)) A (assoc_list_of_array a)"
proof(cases a)
  case (Array xs)
  obtain ys where [simp]: "A = Array ys" by(cases A)
  with Array len have "length xs  length ys" by simp
  hence "foldr (λx y. array_set y (fst x) (f (fst x) (snd x)))
               (rev (zip [0..<length xs] xs)) (Array ys) =
         Array (map (λx. f (fst x) (snd x)) (zip [0..<length xs] xs) @ drop (length xs) ys)"
  proof(induct xs arbitrary: ys rule: rev_induct)
    case Nil thus ?case by simp
  next
    case (snoc x xs ys)
    from ‹length (xs @ [x])  length ys have "length xs  length ys" by simp
    hence "foldr (λx y. array_set y (fst x) (f (fst x) (snd x)))
                 (rev (zip [0..<length xs] xs)) (Array ys) =
           Array (map (λx. f (fst x) (snd x)) (zip [0..<length xs] xs) @ drop (length xs) ys)"
      by(rule snoc)
    moreover from ‹length (xs @ [x])  length ys
    obtain y ys' where ys: "drop (length xs) ys = y # ys'"
      by(cases "drop (length xs) ys") auto
    moreover hence "drop (Suc (length xs)) ys = ys'" by(auto dest: drop_eq_ConsD)
    ultimately show ?case by(simp add: list_update_append)
  qed
  thus ?thesis using Array len
    by(simp add: array_map_def split_beta array_of_list_def foldl_conv_foldr)
qed

subsection ‹Lemmas about empty arrays›

lemma array_length_eq_0 [simp]:
  "array_length a = 0  a = Array []"
by(cases a) simp

lemma new_array_0 [simp]: "new_array v 0 = Array []"
by(simp add: new_array_def)

lemma array_of_list_Nil [simp]:
  "array_of_list [] = Array []"
by(simp add: array_of_list_def)

lemma array_map_Nil [simp]:
  "array_map f (Array []) = Array []"
by(simp add: array_map_def)

lemma array_foldl_Nil [simp]:
  "array_foldl f b (Array []) = b"
by(simp add: array_foldl_def)

lemma array_foldr_Nil [simp]:
  "array_foldr f (Array []) b = b"
by(simp add: array_foldr_def)

lemma prod_foldl_conv:
  "(foldl f a xs, foldl g b xs) = foldl (λ(a, b) x. (f a x, g b x)) (a, b) xs"
by(induct xs arbitrary: a b) simp_all

lemma prod_array_foldl_conv:
  "(array_foldl f b a, array_foldl g c a) = array_foldl (λh (b, c) v. (f h b v, g h c v)) (b, c) a"
by(cases a)(simp add: array_foldl_def foldl_map prod_foldl_conv split_def)

lemma array_foldl_array_foldr_comm:
  "comp_fun_commute (λ(h, v) b. f h b v)  array_foldl f b a = array_foldr (λh v b. f h b v) a b"
by(cases a)(simp add: array_foldl_def array_foldr_def split_def comp_fun_commute.foldr_conv_foldl)

lemma array_map_conv_array_foldl:
  "array_map f a = array_foldl (λh a v. array_set a h (f h v)) a a"
proof(cases a)
  case (Array xs)
  define a where "a = xs"
  hence "length xs  length a" by simp
  hence "foldl (λa (k, v). array_set a k (f k v))
              (Array a) (zip [0..<length xs] xs)
         = Array (map (λ(k, v). f k v) (zip [0..<length xs] xs) @ drop (length xs) a)"
  proof(induct xs rule: rev_induct)
    case Nil thus ?case by simp
  next
    case (snoc x xs)
    have "foldl (λa (k, v). array_set a k (f k v)) (Array a) (zip [0..<length (xs @ [x])] (xs @ [x])) =
          array_set (foldl (λa (k, v). array_set a k (f k v)) (Array a) (zip [0..<length xs] xs))
                    (length xs) (f (length xs) x)" by simp
    also from ‹length (xs @ [x])  length a have "length xs  length a" by simp
    hence "foldl (λa (k, v). array_set a k (f k v)) (Array a) (zip [0..<length xs] xs) =
           Array (map (λ(k, v). f k v) (zip [0..<length xs] xs) @ drop (length xs) a)" by(rule snoc)
    also note array_set.simps
    also have "(map (λ(k, v). f k v) (zip [0..<length xs] xs) @ drop (length xs) a) [length xs := f (length xs) x] =
              (map (λ(k, v). f k v) (zip [0..<length xs] xs) @ (drop (length xs) a) [0 := f (length xs) x])"
      by(simp add: list_update_append)
    also from ‹length (xs @ [x])  length a
    have "(drop (length xs) a)[0 := f (length xs) x] =
          f (length xs) x # drop (Suc (length xs)) a"
      by(simp add: upd_conv_take_nth_drop)
    also have "map (λ(k, v). f k v) (zip [0..<length xs] xs) @ f (length xs) x # drop (Suc (length xs)) a =
             (map (λ(k, v). f k v) (zip [0..<length xs] xs) @ [f (length xs) x]) @ drop (Suc (length xs)) a" by simp
    also have " = map (λ(k, v). f k v) (zip [0..<length (xs @ [x])] (xs @ [x])) @ drop (length (xs @ [x])) a"
      by(simp)
    finally show ?case .
  qed
  with a_def Array show ?thesis
    by(simp add: array_foldl_def array_map_def array_of_list_def)
qed

lemma array_foldl_new_array:
  "array_foldl f b (new_array a n) = foldl (λb (k, v). f k b v) b (zip [0..<n] (replicate n a))"
  by(simp add: new_array_def array_foldl_def)

lemma array_list_of_set[simp]:
  "list_of_array (array_set a i x) = (list_of_array a) [i := x]"
  by (cases a) simp

lemma array_length_list: "array_length a = length (list_of_array a)"
  by (cases a) simp


subsection ‹Parametricity lemmas›

lemma rec_array_is_case[simp]: "rec_array = case_array"
  apply (intro ext)
  apply (auto split: array.split)
  done

definition array_rel_def_internal:
  "array_rel R 
    {(Array xs, Array ys)|xs ys. (xs,ys)  Rlist_rel}"

lemma array_rel_def:
  "Rarray_rel  {(Array xs, Array ys)|xs ys. (xs,ys)  Rlist_rel}"
  unfolding array_rel_def_internal relAPP_def .

lemma array_relD:
  "(Array l, Array l')  Rarray_rel  (l,l')  Rlist_rel"
  by (simp add: array_rel_def)

lemma array_rel_alt:
  "Rarray_rel =
  { (Array l, l) | l. True }
  O Rlist_rel
  O {(l,Array l) | l. True}"
  by (auto simp: array_rel_def)

lemma array_rel_sv[relator_props]:
  shows "single_valued R  single_valued (Rarray_rel)"
  unfolding array_rel_alt
  apply (intro relator_props )
  apply (auto intro: single_valuedI)
  done

lemma param_Array[param]:
  "(Array,Array)  R list_rel  R array_rel"
  apply (intro fun_relI)
  apply (simp add: array_rel_def)
  done

lemma param_rec_array[param]:
  "(rec_array,rec_array)  (Ralist_rel  Rb)  Raarray_rel  Rb"
  apply (intro fun_relI)
  apply (rename_tac f f' a a', case_tac a, case_tac a')
  apply (auto dest: fun_relD array_relD)
  done

lemma param_case_array[param]:
  "(case_array,case_array)  (Ralist_rel  Rb)  Raarray_rel  Rb"
  apply (clarsimp split: array.split)
  apply (drule array_relD)
  by parametricity

lemma param_case_array1':
  assumes "(a,a')Raarray_rel"
  assumes "l l'.  a=Array l; a'=Array l'; (l,l')Ralist_rel 
     (f l,f' l')  Rb"
  shows "(case_array f a,case_array f' a')  Rb"
  using assms
  apply (clarsimp split: array.split)
  apply (drule array_relD)
  apply parametricity
  by (rule refl)+

lemmas param_case_array2' = param_case_array1'[folded rec_array_is_case]

lemmas param_case_array' = param_case_array1' param_case_array2'

lemma param_array_length[param]:
    "(array_length,array_length)  Rbarray_rel  nat_rel"
  unfolding array_length_def
  by parametricity

lemma param_array_grow[param]:
  "(array_grow,array_grow)  Rarray_rel  nat_rel  R  Rarray_rel"
   unfolding array_grow_def by parametricity

lemma array_rel_imp_same_length:
  "(a, a')  Rarray_rel  array_length a = array_length a'"
  apply (cases a, cases a')
  apply (auto simp add: list_rel_imp_same_length dest!: array_relD)
  done

lemma param_array_get[param]:
  assumes I: "i<array_length a"
  assumes IR: "(i,i')nat_rel"
  assumes AR: "(a,a')Rarray_rel"
  shows "(array_get a i, array_get a' i')  R"
proof -
  obtain l l' where [simp]: "a = Array l" "a' = Array l'"
      by (cases a, cases a', simp_all)
  from AR have LR: "(l,l')  Rlist_rel" by (force dest!: array_relD)
  thus ?thesis using assms
    unfolding array_get_def
    apply (auto intro!: param_nth[param_fo] dest: list_rel_imp_same_length)
    done
qed

lemma param_array_set[param]:
  "(array_set,array_set)Rarray_relnat_relRRarray_rel"
  unfolding array_set_def by parametricity

lemma param_array_of_list[param]:
  "(array_of_list, array_of_list)  R list_rel  R array_rel"
  unfolding array_of_list_def by parametricity

lemma param_array_shrink[param]:
  assumes N: "array_length a  n"
  assumes NR: "(n,n')nat_rel"
  assumes AR: "(a,a')Rarray_rel"
  shows "(array_shrink a n, array_shrink a' n')  R array_rel"
proof-
  obtain l l' where [simp]: "a = Array l" "a' = Array l'"
      by (cases a, cases a', simp_all)
  from AR have LR: "(l,l')  Rlist_rel"
    by (auto dest: array_relD)
  with assms show ?thesis by (auto intro:
      param_Array[param_fo] param_take[param_fo]
      dest: array_rel_imp_same_length
    )
qed

lemma param_assoc_list_of_array[param]:
  "(assoc_list_of_array, assoc_list_of_array) 
       R array_rel  nat_rel,Rprod_rellist_rel"
  unfolding assoc_list_of_array_def[abs_def] by parametricity

lemma param_array_map[param]:
  "(array_map, array_map) 
       (nat_rel  Ra  Rb)  Raarray_rel  Rbarray_rel"
  unfolding array_map_def[abs_def] by parametricity

lemma param_array_foldr[param]:
  "(array_foldr, array_foldr) 
       (nat_rel  Ra  Rb  Rb)  Raarray_rel  Rb  Rb"
  unfolding array_foldr_def[abs_def] by parametricity

lemma param_array_foldl[param]:
  "(array_foldl, array_foldl) 
       (nat_rel  Rb  Ra  Rb)  Rb  Raarray_rel  Rb"
  unfolding array_foldl_def[abs_def] by parametricity

subsection ‹Code Generator Setup›

subsubsection ‹Code-Numeral Preparation›

definition [code del]: "new_array' v == new_array v o nat_of_integer"
definition [code del]: "array_length' == integer_of_nat o array_length"
definition [code del]: "array_get' a == array_get a o nat_of_integer"
definition [code del]: "array_set' a == array_set a o nat_of_integer"
definition [code del]: "array_grow' a == array_grow a o nat_of_integer"
definition [code del]: "array_shrink' a == array_shrink a o nat_of_integer"
definition [code del]:
  "array_get_oo' x a == array_get_oo x a o nat_of_integer"
definition [code del]:
  "array_set_oo' f a == array_set_oo f a o nat_of_integer"


lemma [code]:
  "new_array v == new_array' v o integer_of_nat"
  "array_length == nat_of_integer o array_length'"
  "array_get a == array_get' a o integer_of_nat"
  "array_set a == array_set' a o integer_of_nat"
  "array_grow a == array_grow' a o integer_of_nat"
  "array_shrink a == array_shrink' a o integer_of_nat"
  "array_get_oo x a == array_get_oo' x a o integer_of_nat"
  "array_set_oo f a == array_set_oo' f a o integer_of_nat"
  by (simp_all
    add: o_def
    add: new_array'_def array_length'_def array_get'_def array_set'_def
      array_grow'_def array_shrink'_def array_get_oo'_def array_set_oo'_def)

text ‹Fallbacks›
lemmas [code] = array_get_oo'_def[unfolded array_get_oo_def[abs_def]]
lemmas [code] = array_set_oo'_def[unfolded array_set_oo_def[abs_def]]

subsubsection ‹Code generator setup for Haskell›

code_printing type_constructor array 
  (Haskell) "Array.ArrayType/ _"

code_reserved Haskell array_of_list

(*
code_printing code_module "Array" ⇀
  (Haskell) {*
--import qualified Data.Array.Diff as Arr;
import qualified Data.Array as Arr;
import Data.Array.IArray;
import Nat;

instance Ix Nat where {
    range (Nat a, Nat b) = map Nat (range (a, b));
    index (Nat a, Nat b) (Nat c) = index (a,b) c;
    inRange (Nat a, Nat b) (Nat c) = inRange (a, b) c;
    rangeSize (Nat a, Nat b) = rangeSize (a, b);
};

type ArrayType = Arr.DiffArray Nat;
--type ArrayType = Arr.Array Nat;

-- we need to start at 1 and not 0, because the empty array
-- is modelled by having s > e for (s,e) = bounds
-- and as we are in Nat, 0 is the smallest number

array_of_size :: Nat -> [e] -> ArrayType e;
array_of_size n = Arr.listArray (1, n);

new_array :: e -> Nat -> ArrayType e;
new_array a n = array_of_size n (repeat a);

array_length :: ArrayType e -> Nat;
array_length a = let (s, e) = bounds a in if s > e then 0 else e - s + 1;
-- the `if` is actually needed, because in Nat we have s > e --> e - s + 1 = 1

array_get :: ArrayType e -> Nat -> e;
array_get a i = a ! (i + 1);

array_set :: ArrayType e -> Nat -> e -> ArrayType e;
array_set a i e = a // [(i + 1, e)];

array_of_list :: [e] -> ArrayType e;
array_of_list xs = array_of_size (fromInteger (toInteger (length xs - 1))) xs;

array_grow :: ArrayType e -> Nat -> e -> ArrayType e;
array_grow a i x = let (s, e) = bounds a in Arr.listArray (s, e+i) (Arr.elems a ++ repeat x);

array_shrink :: ArrayType e -> Nat -> ArrayType e;
array_shrink a sz = if sz > array_length a then undefined else array_of_size sz (Arr.elems a);
*}
*)

(* TODO/FIXME: Using standard functional arrays here, as DiffArray seems 
  to be discontinued in Haskell! *)
code_printing code_module "Array" 
  (Haskell) ‹module Array where {

--import qualified Data.Array.Diff as Arr;
import qualified Data.Array as Arr;

type ArrayType = Arr.Array Integer;


array_of_size :: Integer -> [e] -> ArrayType e;
array_of_size n = Arr.listArray (0, n-1);

new_array :: e -> Integer -> ArrayType e;
new_array a n = array_of_size n (repeat a);

array_length :: ArrayType e -> Integer;
array_length a = let (s, e) = Arr.bounds a in e;

array_get :: ArrayType e -> Integer -> e;
array_get a i = a Arr.! i;

array_set :: ArrayType e -> Integer -> e -> ArrayType e;
array_set a i e = a Arr.// [(i, e)];

array_of_list :: [e] -> ArrayType e;
array_of_list xs = array_of_size (toInteger (length xs)) xs;

array_grow :: ArrayType e -> Integer -> e -> ArrayType e;
array_grow a i x = let (s, e) = Arr.bounds a in Arr.listArray (s, e+i) (Arr.elems a ++ repeat x);

array_shrink :: ArrayType e -> Integer -> ArrayType e;
array_shrink a sz = if sz > array_length a then undefined else array_of_size sz (Arr.elems a);
}›




code_printing constant Array  (Haskell) "Array.array'_of'_list"
code_printing constant new_array'  (Haskell) "Array.new'_array"
code_printing constant array_length'  (Haskell) "Array.array'_length"
code_printing constant array_get'  (Haskell) "Array.array'_get"
code_printing constant array_set'  (Haskell) "Array.array'_set"
code_printing constant array_of_list  (Haskell) "Array.array'_of'_list"
code_printing constant array_grow'  (Haskell) "Array.array'_grow"
code_printing constant array_shrink'  (Haskell) "Array.array'_shrink"

subsubsection ‹Code Generator Setup For SML›

text ‹
  We have the choice between single-threaded arrays, that raise an exception if an old version is accessed,
  and truly functional arrays, that update the array in place, but store undo-information to restore
  old versions.
›

code_printing code_module "STArray" 
  (SML)
‹
structure STArray = struct

datatype 'a Cell = Invalid | Value of 'a array;

exception AccessedOldVersion;

type 'a array = 'a Cell Unsynchronized.ref;

fun fromList l = Unsynchronized.ref (Value (Array.fromList l));
fun array (size, v) = Unsynchronized.ref (Value (Array.array (size,v)));
fun tabulate (size, f) = Unsynchronized.ref (Value (Array.tabulate(size, f)));
fun sub (Unsynchronized.ref Invalid, idx) = raise AccessedOldVersion |
    sub (Unsynchronized.ref (Value a), idx) = Array.sub (a,idx);
fun update (aref,idx,v) =
  case aref of
    (Unsynchronized.ref Invalid) => raise AccessedOldVersion |
    (Unsynchronized.ref (Value a)) => (
      aref := Invalid;
      Array.update (a,idx,v);
      Unsynchronized.ref (Value a)
    );

fun length (Unsynchronized.ref Invalid) = raise AccessedOldVersion |
    length (Unsynchronized.ref (Value a)) = Array.length a

fun grow (aref, i, x) = case aref of
  (Unsynchronized.ref Invalid) => raise AccessedOldVersion |
  (Unsynchronized.ref (Value a)) => (
    let val len=Array.length a;
        val na = Array.array (len+i,x)
    in
      aref := Invalid;
      Array.copy {src=a, dst=na, di=0};
      Unsynchronized.ref (Value na)
    end
    );

fun shrink (aref, sz) = case aref of
  (Unsynchronized.ref Invalid) => raise AccessedOldVersion |
  (Unsynchronized.ref (Value a)) => (
    if sz > Array.length a then
      raise Size
    else (
      aref:=Invalid;
      Unsynchronized.ref (Value (Array.tabulate (sz,fn i => Array.sub (a,i))))
    )
  );

structure IsabelleMapping = struct
type 'a ArrayType = 'a array;

fun new_array (a:'a) (n:IntInf.int) = array (IntInf.toInt n, a);

fun array_length (a:'a ArrayType) = IntInf.fromInt (length a);

fun array_get (a:'a ArrayType) (i:IntInf.int) = sub (a, IntInf.toInt i);

fun array_set (a:'a ArrayType) (i:IntInf.int) (e:'a) = update (a, IntInf.toInt i, e);

fun array_of_list (xs:'a list) = fromList xs;

fun array_grow (a:'a ArrayType) (i:IntInf.int) (x:'a) = grow (a, IntInf.toInt i, x);

fun array_shrink (a:'a ArrayType) (sz:IntInf.int) = shrink (a,IntInf.toInt sz);

end;

end;

structure FArray = struct
  datatype 'a Cell = Value of 'a Array.array | Upd of (int*'a*'a Cell Unsynchronized.ref);

  type 'a array = 'a Cell Unsynchronized.ref;

  fun array (size,v) = Unsynchronized.ref (Value (Array.array (size,v)));
  fun tabulate (size, f) = Unsynchronized.ref (Value (Array.tabulate(size, f)));
  fun fromList l = Unsynchronized.ref (Value (Array.fromList l));

  fun sub (Unsynchronized.ref (Value a), idx) = Array.sub (a,idx) |
      sub (Unsynchronized.ref (Upd (i,v,cr)),idx) =
        if i=idx then v
        else sub (cr,idx);

  fun length (Unsynchronized.ref (Value a)) = Array.length a |
      length (Unsynchronized.ref (Upd (i,v,cr))) = length cr;

  fun realize_aux (aref, v) =
    case aref of
      (Unsynchronized.ref (Value a)) => (
        let
          val len = Array.length a;
          val a' = Array.array (len,v);
        in
          Array.copy {src=a, dst=a', di=0};
          Unsynchronized.ref (Value a')
        end
      ) |
      (Unsynchronized.ref (Upd (i,v,cr))) => (
        let val res=realize_aux (cr,v) in
          case res of
            (Unsynchronized.ref (Value a)) => (Array.update (a,i,v); res)
        end
      );

  fun realize aref =
    case aref of
      (Unsynchronized.ref (Value _)) => aref |
      (Unsynchronized.ref (Upd (i,v,cr))) => realize_aux(aref,v);

  fun update (aref,idx,v) =
    case aref of
      (Unsynchronized.ref (Value a)) => (
        let val nref=Unsynchronized.ref (Value a) in
          aref := Upd (idx,Array.sub(a,idx),nref);
          Array.update (a,idx,v);
          nref
        end
      ) |
      (Unsynchronized.ref (Upd _)) =>
        let val ra = realize_aux(aref,v) in
          case ra of
            (Unsynchronized.ref (Value a)) => Array.update (a,idx,v);
          ra
        end
      ;

  fun grow (aref, inc, x) = case aref of
    (Unsynchronized.ref (Value a)) => (
      let val len=Array.length a;
          val na = Array.array (len+inc,x)
      in
        Array.copy {src=a, dst=na, di=0};
        Unsynchronized.ref (Value na)
      end
      )
  | (Unsynchronized.ref (Upd _)) => (
    grow (realize aref, inc, x)
  );

  fun shrink (aref, sz) = case aref of
    (Unsynchronized.ref (Value a)) => (
      if sz > Array.length a then
        raise Size
      else (
        Unsynchronized.ref (Value (Array.tabulate (sz,fn i => Array.sub (a,i))))
      )
    ) |
    (Unsynchronized.ref (Upd _)) => (
      shrink (realize aref,sz)
    );

structure IsabelleMapping = struct
type 'a ArrayType = 'a array;

fun new_array (a:'a) (n:IntInf.int) = array (IntInf.toInt n, a);

fun array_length (a:'a ArrayType) = IntInf.fromInt (length a);

fun array_get (a:'a ArrayType) (i:IntInf.int) = sub (a, IntInf.toInt i);

fun array_set (a:'a ArrayType) (i:IntInf.int) (e:'a) = update (a, IntInf.toInt i, e);

fun array_of_list (xs:'a list) = fromList xs;

fun array_grow (a:'a ArrayType) (i:IntInf.int) (x:'a) = grow (a, IntInf.toInt i, x);

fun array_shrink (a:'a ArrayType) (sz:IntInf.int) = shrink (a,IntInf.toInt sz);

fun array_get_oo (d:'a) (a:'a ArrayType) (i:IntInf.int) =
  sub (a,IntInf.toInt i) handle Subscript => d

fun array_set_oo (d:(unit->'a ArrayType)) (a:'a ArrayType) (i:IntInf.int) (e:'a) =
  update (a, IntInf.toInt i, e) handle Subscript => d ()

end;
end;


›

code_printing
  type_constructor array  (SML) "_/ FArray.IsabelleMapping.ArrayType"
| constant Array  (SML) "FArray.IsabelleMapping.array'_of'_list"
| constant new_array'  (SML) "FArray.IsabelleMapping.new'_array"
| constant array_length'  (SML) "FArray.IsabelleMapping.array'_length"
| constant array_get'  (SML) "FArray.IsabelleMapping.array'_get"
| constant array_set'  (SML) "FArray.IsabelleMapping.array'_set"
| constant array_grow'  (SML) "FArray.IsabelleMapping.array'_grow"
| constant array_shrink'  (SML) "FArray.IsabelleMapping.array'_shrink"
| constant array_of_list  (SML) "FArray.IsabelleMapping.array'_of'_list"
| constant array_get_oo'  (SML) "FArray.IsabelleMapping.array'_get'_oo"
| constant array_set_oo'  (SML) "FArray.IsabelleMapping.array'_set'_oo"


subsection ‹Code Generator Setup for Scala›
text ‹
  We use a DiffArray-Implementation in Scala.
›
code_printing code_module "DiffArray" 
  (Scala) ‹
object DiffArray {

  import scala.collection.mutable.ArraySeq

  protected abstract sealed class DiffArray_D[A]
  final case class Current[A] (a:ArraySeq[AnyRef]) extends DiffArray_D[A]
  final case class Upd[A] (i:Int, v:A, n:DiffArray_D[A]) extends DiffArray_D[A]

  object DiffArray_Realizer {
    def realize[A](a:DiffArray_D[A]) : ArraySeq[AnyRef] = a match {
      case Current(a) => ArraySeq.empty ++ a
      case Upd(j,v,n) => {val a = realize(n); a.update(j, v.asInstanceOf[AnyRef]); a}
    }
  }

  class T[A] (var d:DiffArray_D[A]) {

    def realize (): ArraySeq[AnyRef] = { val a=DiffArray_Realizer.realize(d); d = Current(a); a }
    override def toString() = realize().toSeq.toString

    override def equals(obj:Any) =
      if (obj.isInstanceOf[T[A]]) obj.asInstanceOf[T[A]].realize().equals(realize())
      else false

  }


  def array_of_list[A](l : List[A]) : T[A] = new T(Current(ArraySeq.empty ++ l.asInstanceOf[List[AnyRef]]))
  def new_array[A](v:A, sz : BigInt) = new T[A](Current[A](ArraySeq.fill[AnyRef](sz.intValue)(v.asInstanceOf[AnyRef])))

  private def length[A](a:DiffArray_D[A]) : BigInt = a match {
    case Current(a) => a.length
    case Upd(_,_,n) => length(n)
  }

  def length[A](a : T[A]) : BigInt = length(a.d)

  private def sub[A](a:DiffArray_D[A], i:Int) : A = a match {
    case Current(a) => a(i).asInstanceOf[A]
    case Upd(j,v,n) => if (i==j) v else sub(n,i)
  }

  def get[A](a:T[A], i:BigInt) : A = sub(a.d,i.intValue)

  private def realize[A](a:DiffArray_D[A]): ArraySeq[AnyRef] = DiffArray_Realizer.realize[A](a)

  def set[A](a:T[A], i:BigInt,v:A) : T[A] = a.d match {
    case Current(ad) => {
      val ii = i.intValue;
      a.d = Upd(ii,ad(ii).asInstanceOf[A],a.d);
      //ad.update(ii,v);
      ad(ii)=v.asInstanceOf[AnyRef]
      new T[A](Current(ad))
    }
    case Upd(_,_,_) => set(new T[A](Current(realize(a.d))), i.intValue,v)
  }

  def grow[A](a:T[A], sz:BigInt, v:A) : T[A] = a.d match {
    case Current(ad) => {
      val adt = ArraySeq.fill[AnyRef](sz.intValue)(v.asInstanceOf[AnyRef])
      System.arraycopy(ad.array, 0, adt.array, 0, ad.length);
      new T[A](Current[A](adt))
    }
    case Upd (_,_,_) =>  {
      val adt = ArraySeq.fill[AnyRef](sz.intValue)(v.asInstanceOf[AnyRef])
      val ad = realize(a.d)
      System.arraycopy(ad.array, 0, adt.array, 0, ad.length);
      new T[A](Current[A](adt))
    }
  }

  def shrink[A](a:T[A], sz:BigInt) : T[A] =
    if (sz==0) {
      array_of_list(Nil)
    } else {
      a.d match {
        case Current(ad) => {
          val v=ad(0);
          val szz=sz.intValue
          val adt = ArraySeq.fill[AnyRef](szz)(v);
          System.arraycopy(ad.array, 0, adt.array, 0, szz);
          new T[A](Current[A](adt))
        }
        case Upd (_,_,_) =>  {
          val ad = realize(a.d);
          val szz=sz.intValue
          val v=ad(0);
          val adt = ArraySeq.fill[AnyRef](szz)(v);
          System.arraycopy(ad.array, 0, adt.array, 0, szz);
          new T[A](Current[A](adt))
        }
      }
    }

  def get_oo[A](d: => A, a:T[A], i:BigInt):A = try get(a,i) catch {
    case _:scala.IndexOutOfBoundsException => d
  }

  def set_oo[A](d: Unit => T[A], a:T[A], i:BigInt, v:A) : T[A] = try set(a,i,v) catch {
    case _:scala.IndexOutOfBoundsException => d(())
  }

}

/*
object Test {



  def assert (b : Boolean) : Unit = if (b) () else throw new java.lang.AssertionError("Assertion Failed")

  def eql[A] (a:DiffArray.T[A], b:List[A]) = assert (a.realize.corresponds(b)((x,y) => x.equals(y)))


  def tests1(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Simple update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Another update
    val c = DiffArray.set(b,3,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::9::Nil)

    // Update of old version (forces realize)
    val d = DiffArray.set(b,2,8)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::9::Nil)
      eql(d,1::2::8::4::Nil)

    }

  def tests2(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Simple update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Grow of current version
    val c = DiffArray.grow(b,6,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::4::9::9::Nil)

    // Grow of old version
    val d = DiffArray.grow(a,6,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::4::9::9::Nil)
      eql(d,1::2::3::4::9::9::Nil)

  }

  def tests3(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Simple update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Shrink of current version
    val c = DiffArray.shrink(b,3)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::Nil)

    // Shrink of old version
    val d = DiffArray.shrink(a,3)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::Nil)
      eql(d,1::2::3::Nil)

  }

  def tests4(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Update _oo (succeeds)
    val b = DiffArray.set_oo((_) => a,a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Update _oo (current version,fails)
    val c = DiffArray.set_oo((_) => a,b,5,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::3::4::Nil)

    // Update _oo (old version,fails)
    val d = DiffArray.set_oo((_) => b,a,5,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::3::4::Nil)
      eql(d,1::2::9::4::Nil)

  }

  def tests5(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Get_oo (current version, succeeds)
      assert (DiffArray.get_oo(0,b,2)==9)
    // Get_oo (current version, fails)
      assert (DiffArray.get_oo(0,b,5)==0)
    // Get_oo (old version, succeeds)
      assert (DiffArray.get_oo(0,a,2)==3)
    // Get_oo (old version, fails)
      assert (DiffArray.get_oo(0,a,5)==0)

  }




  def main(args: Array[String]): Unit = {
    tests1 ()
    tests2 ()
    tests3 ()
    tests4 ()
    tests5 ()


    Console.println("Tests passed")
  }

}*/

›

code_printing
  type_constructor array  (Scala) "DiffArray.T[_]"
| constant Array  (Scala) "DiffArray.array'_of'_list"
| constant new_array'  (Scala) "DiffArray.new'_array((_),(_).toInt)"
| constant array_length'  (Scala) "DiffArray.length((_)).toInt"
| constant array_get'  (Scala) "DiffArray.get((_),(_).toInt)"
| constant array_set'  (Scala) "DiffArray.set((_),(_).toInt,(_))"
| constant array_grow'  (Scala) "DiffArray.grow((_),(_).toInt,(_))"
| constant array_shrink'  (Scala) "DiffArray.shrink((_),(_).toInt)"
| constant array_of_list  (Scala) "DiffArray.array'_of'_list"
| constant array_get_oo'  (Scala) "DiffArray.get'_oo((_),(_),(_).toInt)"
| constant array_set_oo'  (Scala) "DiffArray.set'_oo((_),(_),(_).toInt,(_))"

context begin
(*private*) definition "test_diffarray_setup  (Array,new_array',array_length',array_get', array_set', array_grow', array_shrink',array_of_list,array_get_oo',array_set_oo')"
export_code test_diffarray_setup checking Scala SML OCaml? Haskell?
end

end

Theory Partial_Equivalence_Relation

theory Partial_Equivalence_Relation
imports Main
begin

subsection ‹Partial Equivalence Relations›
text ‹
  The abstract datatype for a union-find structure is a partial equivalence
  relation.
›

definition "part_equiv R  sym R  trans R"

lemma part_equivI[intro?]: "sym R; trans R  part_equiv R" 
  by (simp add: part_equiv_def)

lemma part_equiv_refl:
  "part_equiv R  (x,y)R  (x,x)R"
  "part_equiv R  (x,y)R  (y,y)R"
  by (metis part_equiv_def symD transD)+

lemma part_equiv_sym: "part_equiv R  (x,y)R  (y,x)R"
  by (metis part_equiv_def symD)

lemma part_equiv_trans: "part_equiv R  (x,y)R  (y,z)R  (x,z)R"
  by (metis part_equiv_def transD)

lemma part_equiv_trans_sym: 
  " part_equiv R; (a,b)R; (c,b)R   (a,c)R"
  " part_equiv R; (a,b)R; (a,c)R   (b,c)R"
  apply (metis part_equiv_sym part_equiv_trans)+
  done

text ‹We define a shortcut for symmetric closure.›
definition "symcl R  R  R¯"

lemma sym_symcl[simp, intro!]: "sym (symcl R)"
  by (metis sym_Un_converse symcl_def)
lemma sym_trans_is_part_equiv[simp, intro!]: "part_equiv ((symcl R)*)"
  by (metis part_equiv_def sym_rtrancl sym_symcl trans_rtrancl)

text ‹We also define a shortcut for melding the equivalence classes of
  two given elements›
definition per_union where "per_union R a b  R  
  { (x,y). (x,a)R  (y,b)R }  { (y,x). (x,a)R  (y,b)R }"

lemma union_part_equivp: 
  "part_equiv R  part_equiv (per_union R a b)"
  apply rule
  unfolding per_union_def
  apply (rule symI)
  apply (auto dest: part_equiv_sym) []

  apply (rule transI)
  apply (auto dest: part_equiv_trans part_equiv_trans_sym)
  done

lemma per_union_cmp: 
  " part_equiv R; (l,j)R   per_union R l j = R"
  unfolding per_union_def by (auto dest: part_equiv_trans_sym)

lemma per_union_same[simp]: "part_equiv R  per_union R l l = R"
  unfolding per_union_def by (auto dest: part_equiv_trans_sym)

lemma per_union_commute[simp]: "per_union R i j = per_union R j i"
  unfolding per_union_def by auto

lemma per_union_dom[simp]: "Domain (per_union R i j) = Domain R"
  unfolding per_union_def by auto

lemma per_classes_dj: 
  "part_equiv R; (i,j)R  R``{i}  R``{j} = {}"
  by (auto dest: part_equiv_trans_sym)

lemma per_class_in_dom: "part_equiv R  R``{i}  Domain R"
  by (auto dest: part_equiv_trans_sym)

end

Theory ICF_Tools

section ‹General ML-level tools›
theory ICF_Tools
imports Main
begin

lemma meta_same_imp_rule: "(PROP P; PROP P  PROP Q)  (PROP P  PROP Q)"
  by rule
(* TODO: Replace by distinct_prems_rl *)

ML infix 0 ##;

  fun (f ## g) (a,b) = (f a, g b)

  signature ICF_TOOLS = sig
    (* Generic *)
    val gen_variant: (string -> bool) -> string -> string
    val map_option: ('a -> 'b) -> 'a option -> 'b option

    val parse_cpat: cterm context_parser

    val rename_cterm: (cterm * cterm) ->
      ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list
    val renames_cterm: (cterm * cterm) -> bool

    val import_cterm: cterm -> Proof.context -> cterm * Proof.context
    val inst_meta_cong: Proof.context -> cterm -> thm

    (*
    val thms_from_main: string -> thm list
    val thm_from_main: string -> thm
    *)

    val sss_add: thm list -> Proof.context -> Proof.context

    val changed_conv: conv -> conv
    val repeat_top_sweep_conv: (Proof.context -> conv) -> Proof.context -> conv

    val rem_dup_prems: Proof.context -> thm -> thm

    (* Definition Theorems *)
    val dest_def_eq: term -> term * term
    val norm_def_thm: thm -> thm
    val dthm_lhs: thm -> term
    val dthm_rhs: thm -> term
    val dthm_params: thm -> term list
    val dthm_head: thm -> term

    val dt_lhs: term -> term
    val dt_rhs: term -> term
    val dt_params: term -> term list
    val dt_head: term -> term

    val chead_of: cterm -> cterm
    val chead_of_thm: thm -> cterm

    (* Simple definition: name≡term, fixes variables *)
    val define_simple: string -> term -> local_theory 
      -> ((term * thm) * local_theory)

    (* Wrapping stuff inside local theory context *)
    val wrap_lthy_result_global: (local_theory -> 'a * local_theory) ->
        (morphism -> 'a -> 'b) -> theory -> 'b * theory
    val wrap_lthy_global: (local_theory -> local_theory) -> theory -> theory
    val wrap_lthy_result_local: (local_theory -> 'a * local_theory) ->
        (morphism -> 'a -> 'b) -> local_theory -> 'b * local_theory
    val wrap_lthy_local: (local_theory -> local_theory) -> 
        local_theory -> local_theory

    (* Wrapped versions of simple definition *)
    val define_simple_global: string -> term -> theory 
      -> ((term * thm) * theory)
    val define_simple_local: string -> term -> local_theory 
      -> ((term * thm) * local_theory)

    (* Revert abbreviations matching pattern (TODO/FIXME: HACK) *)
    val revert_abbrevs: string -> theory -> theory

  end;

  structure ICF_Tools: ICF_TOOLS = struct
    fun gen_variant decl s = let
      fun search s = if not (decl s) then s else search (Symbol.bump_string s);
    in
      if not (decl s) then s 
      else search (Symbol.bump_init s)
    end;    


    val parse_cpat =
      Args.context --
        Scan.lift Args.embedded_inner_syntax >> (fn (ctxt, str) => 
          Proof_Context.read_term_pattern ctxt str
          |> Thm.cterm_of ctxt 
        );


    (* Renaming first-order match *)
    fun rename_cterm (ct1,ct2) = (
      Thm.first_order_match (ct2,ct1);
      Thm.first_order_match (ct1,ct2));

    val renames_cterm = can rename_cterm;

    fun import_cterm ct ctxt = let
      val (t', ctxt') = yield_singleton (Variable.import_terms true) 
        (Thm.term_of ct) ctxt;
      val ct' = Thm.cterm_of ctxt' t';
    in (ct', ctxt') end

  (* Get theorem by name, that is visible in HOL.Main. Moreover, the
    theory of this theorem will be HOL.Main, which is required to avoid
    non-trivial theory merges as they may occur when using thm-antiquotation.
    (cf. post 
      https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2012-August/msg00175.html 
    on Isabelle mailing list)
  *)(*
  fun thms_from_main name = let
    val xthmref = Facts.named name;
    val thy = @{theory Main};
    val name = Facts.ref_name xthmref
    |> Global_Theory.intern_fact thy;
    val name = case name of "_" => "Pure.asm_rl" | name => name;

    val fs = Global_Theory.facts_of thy;
    val thms = Facts.lookup (Context.Theory thy) fs name
    |> the |> #2 |> map (Thm.transfer thy);
  in thms end

  fun thm_from_main name = thms_from_main name |> Facts.the_single (name, Position.none)
*)
    (* Unfold with simpset 
    fun unfold_ss ss = let
      val simple_prover =
        SINGLE o (fn ss => ALLGOALS (resolve_tac (Raw_Simplifier.prems_of ss)));
    in Raw_Simplifier.rewrite_thm (true,false,false) simple_prover ss end;
    *)

    local
      fun sss_add_single thm ss = let
        val simps = Raw_Simplifier.dest_ss (simpset_of ss) |> #simps |> map #2;
        val ess = ss delsimps simps;
        val thm' = simplify ss thm;

        val new_simps = simps
          |> map (simplify 
              (ess addsimps [thm']));
        val ss' = ess addsimps (thm'::new_simps)
      in ss' end
    in
      val sss_add = fold sss_add_single
    end

    local
      open Conv;
    in
      fun changed_conv cnv = (fn (ct:cterm) => let
        val thm = cnv ct
      in
        if Thm.is_reflexive thm then 
          raise THM ("changed_conv: Not changed",~1,[thm])
        else thm
      end)

      fun repeat_top_sweep_conv cnv ctxt = 
        repeat_conv (changed_conv (top_sweep_conv cnv ctxt));
    end

    (* Remove duplicate premises (stable) *)
    fun rem_dup_prems ctxt thm = let
      val prems = Thm.prems_of thm;
      val perm = prems
      |> tag_list 0 
      |> map swap 
      |> Termtab.make_list
      |> Termtab.dest 
      |> map snd
      |> sort (int_ord o apply2 hd)
      |> flat;

      val thm' = Drule.rearrange_prems perm thm
        |> Conv.fconv_rule 
             (Raw_Simplifier.rewrite ctxt true @{thms meta_same_imp_rule});
    in thm' end;

    fun dest_def_eq (Const (@{const_name Pure.eq},_)$l$r) = (l,r)
    | dest_def_eq (Const (@{const_name HOL.Trueprop},_)
                    $(Const (@{const_name HOL.eq},_)$l$r)) = (l,r)
    | dest_def_eq t = raise TERM ("No definitional equation",[t]);

    fun norm_def_thm thm =
      case Thm.concl_of thm of
        (Const (@{const_name Pure.eq},_)$_$_) => thm
      | _ => thm RS eq_reflection;

    val dt_lhs = dest_def_eq #> fst;
    val dt_rhs = dest_def_eq #> snd;
    val dt_params = dt_lhs #> strip_comb #> snd;
    val dt_head = dt_lhs #> head_of;

    val dthm_lhs = Thm.concl_of #> dt_lhs;
    val dthm_rhs = Thm.concl_of #> dt_rhs;
    val dthm_params = Thm.concl_of #> dt_params;
    val dthm_head = Thm.concl_of #> dt_head;

    (* Head of function application (cterm) *)
    fun chead_of ct = case Thm.term_of ct of
      (_$_) => chead_of (Thm.dest_fun ct)
      | _ => ct;

    val chead_of_thm = norm_def_thm #> Thm.lhs_of #> chead_of;

    val meta_cong_rl = @{thm "eq_reflection"}
        OF @{thms "arg_cong"} OF @{thms "meta_eq_to_obj_eq"}

    fun inst_meta_cong ctxt ct = let
      val (ct, ctxt') = import_cterm ct ctxt;
      val mc_thm = meta_cong_rl;
      val fpat = mc_thm |> Thm.cprop_of |> Drule.strip_imp_concl 
        |> Thm.dest_arg1 |> chead_of;
      val inst = infer_instantiate ctxt [(#1 (dest_Var (Thm.term_of fpat)), ct)] mc_thm;
      val inst' = singleton (Variable.export ctxt' ctxt) inst;
    in inst' end


    (* Define name≡rhs, generate _def theorem. *)
    fun define_simple name rhs lthy = let 
      (* Import type variables *)
      val (rhs,lthy) = yield_singleton Variable.importT_terms rhs lthy;
      val ((ft,(_,def_thm)),lthy) 
        = Local_Theory.define ((Binding.name name,NoSyn),
         ((Binding.name (Thm.def_name name),[]),rhs)) lthy;
    in ((ft,def_thm),lthy) end;

    fun wrap_lthy_result_global f rmap thy = let
      val lthy = Named_Target.theory_init thy;
      val (r,lthy) = f lthy;
      val (r,thy) = Local_Theory.exit_result_global rmap (r,lthy);
    in
      (r,thy)
    end

    fun wrap_lthy_global f = wrap_lthy_result_global (pair () o f) (K I) #> #2;

    fun wrap_lthy_result_local f rmap lthy = let
      val lthy = (snd o Local_Theory.begin_nested) lthy;
      val (r,lthy) = f lthy;
      val m = Local_Theory.target_morphism lthy;
      val lthy = Local_Theory.end_nested lthy;
      val r = rmap m r;
    in
      (r,lthy)
    end

    fun wrap_lthy_local f = wrap_lthy_result_local (pair () o f) (K I) #> #2;



    (* Define name≡rhs, yielding constant *)
    fun define_simple_global name rhs thy = let
      val lthy = Named_Target.theory_init thy;
      val (r,lthy) = define_simple name rhs lthy;
      fun map_res m (t,thm) = (Morphism.term m t,Morphism.thm m thm);
      val (r,thy) = Local_Theory.exit_result_global (map_res) (r,lthy);
    in (r,thy) end;

    (* Define name≡rhs, yielding constant *)
    fun define_simple_local name rhs lthy = let
      val lthy = (snd o Local_Theory.begin_nested) lthy;
      val (r,lthy) = define_simple name rhs lthy;
      val m = Local_Theory.target_morphism lthy;
      val lthy = Local_Theory.end_nested lthy;
      fun map_res m (t,thm) = (Morphism.term m t,Morphism.thm m thm);
      val (r,lthy) = (map_res m r,lthy);
    in (r,lthy) end;

    fun map_option _ NONE = NONE
      | map_option f (SOME a) = SOME (f a);


    fun revert_abbrevs mpat thy = let
      val ctxt = Proof_Context.init_global thy;
      val match_prefix = if Long_Name.is_qualified mpat then mpat
        else Long_Name.qualify (Context.theory_name thy) mpat;
      val {const_space, constants, ...} = Sign.consts_of thy |> Consts.dest;
      val names = 
      Name_Space.extern_entries true ctxt const_space constants
      |> map_filter (fn
          ((name, _), (_, SOME _)) =>
            if Long_Name.qualifier name = match_prefix then SOME name else NONE
        | _ => NONE)
      val _ = if null names then 
        warning ("ICF_Tools.revert_abbrevs: No names with prefix: " 
          ^ match_prefix) 
      else ();
    in fold (Sign.revert_abbrev "") names thy end


  end;

attribute_setup rem_dup_prems = ‹
  Scan.succeed (Thm.rule_attribute [] (ICF_Tools.rem_dup_prems o Context.proof_of)) "Remove duplicate premises"

method_setup dup_subgoals = ‹
  Scan.succeed (fn ctxt => SIMPLE_METHOD (PRIMITIVE (ICF_Tools.rem_dup_prems ctxt))) "Remove duplicate subgoals"


end

Theory Ord_Code_Preproc

section ‹Functrans simpset for Code Preprocessing›
theory Ord_Code_Preproc
imports Main ICF_Tools
begin

ML signature ORD_CODE_PREPROC = sig
    val add: int * string * (theory -> thm -> thm) -> theory -> theory
    val rem: string -> theory -> theory

    val get: theory -> (int * string * (theory -> thm -> thm)) list

    val setup: theory -> theory
    val trace_enabled: bool Unsynchronized.ref
  end


  structure Ord_Code_Preproc: ORD_CODE_PREPROC = struct
    val trace_enabled = Unsynchronized.ref false

    val do_sort = sort (rev_order o int_ord o apply2 #1)

    structure Data = Theory_Data (
      type T = (int * string * (theory -> thm -> thm)) list
      val empty = []
      val extend = I
      val merge = (op @) #> do_sort #> distinct ((=) o apply2 #2)
    );

    val get = Data.get

    fun add tr = Data.map (fn l => do_sort (tr::l))

    fun rem name = Data.map (filter (fn (_,n,_) => n <>name))

    
    local
      fun trace_ft ft thy thms = if !trace_enabled then let
        val res = ft thy thms;
        val (m1,m2) = case res of NONE => ("NF: ","")
        | SOME thms => ("Preproc: REW: "," --> " ^ @{make_string} thms);

        val _ = tracing (m1 ^ @{make_string} thms ^ m2);
      in res end
      else ft thy thms;

      fun s_functrans ctxt thms =
        let
        val thy = Proof_Context.theory_of ctxt;
        val trs = Data.get thy;
        val process = fold (fn (_,_,tr) => fn thm => tr thy thm) trs;
        val process' = fold (fn (_,name,tr) => fn thm => let
            val thm' = tr thy thm;
            val _ = if !trace_enabled andalso not (Thm.eq_thm (thm,thm')) then
              tracing ("Preproc "^name^": " ^ @{make_string} thm ^ " --> " ^
                @{make_string} thm')
            else ();
          in thm' end
        ) trs;

        fun rew_ch acc ch [] = if ch then SOME acc else NONE
        | rew_ch acc ch (thm::thms) = let
          val thm' = process' thm;
          val ch = ch orelse not (Thm.eq_thm (thm,thm'));
        in rew_ch (thm'::acc) ch thms end;
      in
        rew_ch [] false thms
      end;
    in
      val functrans = ("Functrans_ss.functrans",
        Code_Preproc.simple_functrans ((*trace_ft*) (s_functrans)));
    end;

    val setup = Code_Preproc.add_functrans functrans;

  end

  signature OC_SIMPSET = sig
    val get: theory -> simpset
    val map: (simpset -> simpset) -> theory -> theory
    val setup: theory -> theory
  end

  functor Oc_Simpset(val prio:int val name:string): OC_SIMPSET = struct
    structure Data = Theory_Data (
      type T = simpset
      val empty = empty_ss
      val extend = I
      val merge = Raw_Simplifier.merge_ss
    );

    val get = Data.get
    val map = Data.map

    local 
      fun trans_fun thy thm = let
        val ss = Proof_Context.init_global thy |> put_simpset (get thy)
      in simplify ss thm end;
    in
      val setup = Ord_Code_Preproc.add (prio, name, trans_fun);
    end

  end

setup Ord_Code_Preproc.setup

end

Theory Record_Intf

section ‹Automation for Record Based Interfaces›
theory Record_Intf
  imports Main ICF_Tools Ord_Code_Preproc
begin

text ‹The ICF uses coercions to simulate multiple inheritance of
  operation records›
declare [[coercion_enabled]]

lemma icf_rec_def_rule: "sel B = x; AB   sel A = x " by auto

ML_val Context.mapping


ML signature RECORD_INTF = sig
  val get_unf_ss: Context.generic -> simpset
  val get_unf_thms: Context.generic -> thm list

  val add_unf_thms: thm list -> Context.generic -> Context.generic
  val add_unf_thms_global: thm list -> theory -> theory

  val icf_rec_def: thm -> Context.generic -> Context.generic
  val icf_rec_def_attr: attribute context_parser

  val icf_locales_tac: Proof.context -> tactic

  val setup: theory -> theory
end;

structure Record_Intf: RECORD_INTF = struct
  open ICF_Tools;

  structure Data = Generic_Data
  (
    type T = simpset;
    val empty = HOL_basic_ss (*addsimprocs 
      [Record.simproc, Record.upd_simproc]*);
    val extend = I;
    val merge = Raw_Simplifier.merge_ss;
  );

  structure CppSS = Oc_Simpset (
    val prio = 2;
    val name = "Record_Intf";
  );

  fun get_unf_ss context = Data.get context
  val get_unf_thms = Data.get #> Raw_Simplifier.dest_ss #> #simps #> map #2

  fun add_unf_thms thms context = let
    val ctxt = Context.proof_of context
    fun add ss = simpset_of (put_simpset ss ctxt addsimps thms)
  in
    context 
    |> Data.map add
    |> Context.mapping (CppSS.map add) I
  end

  fun add_unf_thms_global thms = Context.theory_map (add_unf_thms thms);
  
  (* Gather select_conv-, defs- and simps-theorems for given type *)
  fun gather_conv_thms ctxt typ = let
    val thy = Proof_Context.theory_of ctxt
    val infos = Record.dest_recTs typ 
      |> map fst |> map Long_Name.qualifier |> map (Record.the_info thy);
    val cs = map #select_convs infos |> flat |> map (Thm.transfer thy);
    val ds = map #defs infos @ map #simps infos |> flat 
      |> map (Thm.transfer thy);
  in (cs,ds) end

  (* Gather select_conv theorems type of constant defined by def_thm *)
  fun gather_conv_thms_dt ctxt def_thm =
    def_thm |> Thm.prop_of |> Logic.dest_equals |> fst 
    |> fastype_of |> gather_conv_thms ctxt;

  (* Generate code-unfold theorems for definition
    and remove definition from
    code equations. *)

  local
    fun unf_thms_of def_thm context = let
      val ctxt = Context.proof_of context;
      
      val def_thm = norm_def_thm def_thm;

      val (conv_thms, simp_thms) = gather_conv_thms_dt ctxt def_thm;
      val ss = put_simpset (get_unf_ss context) ctxt addsimps simp_thms
      (*val simp_thms = icf_rec_unf.get ctxt @ simp_thms;*)

      val unf_thms = conv_thms 
        |> map (
          chead_of_thm 
          #> inst_meta_cong ctxt
          #> (fn thm => thm OF [def_thm])
          #> simplify ss
        )
        |> filter (not o Thm.is_reflexive);

    in unf_thms end;

  in
    fun icf_rec_def def_thm context =
      let
        val unf_thms = unf_thms_of def_thm context;
        val eqn_heads = the_list (try (fst o dest_Const o fst o strip_comb o fst o Logic.dest_equals
          o Thm.plain_prop_of o Local_Defs.meta_rewrite_rule (Context.proof_of context)) def_thm)
      in
        context
        |> add_unf_thms unf_thms 
        |> not (null eqn_heads) ? Context.mapping (fold Code.declare_aborting_global eqn_heads) I
      end;
  
  end

  val icf_rec_def_attr : attribute context_parser = 
    Scan.succeed (Thm.declaration_attribute icf_rec_def);


  fun icf_locales_tac ctxt = let
    val ss = put_simpset (get_unf_ss (Context.Proof ctxt)) ctxt
    val wits = Locale.get_witnesses ctxt
    val thms = map (simplify ss) wits;
  in ALLGOALS (TRY o (simp_tac ss THEN' resolve_tac ctxt thms)) end


  fun setup_simprocs thy = let
    val ctxt = Proof_Context.init_global thy
    val ss = put_simpset HOL_basic_ss ctxt
      addsimprocs [Record.simproc, Record.upd_simproc]
      |> simpset_of

  in
    Data.map (K ss) (Context.Theory thy) |> Context.the_theory
  end


  val setup = Global_Theory.add_thms_dynamic 
    (@{binding icf_rec_unf}, get_unf_thms)
  #> CppSS.setup
  #> setup_simprocs;


end;

setup Record_Intf.setup

text ‹
  Sets up unfolding for an operation record definition.
  New operation record definitions should be declared as 
  [icf_rec_def]›.
›
attribute_setup icf_rec_def = Record_Intf.icf_rec_def_attr 
  "ICF: Setup unfolding for record definition"

method_setup icf_locales = ‹
  Scan.succeed (fn ctxt => SIMPLE_METHOD (Record_Intf.icf_locales_tac ctxt)) "ICF: Normalize records and discharge locale subgoals"

end

Theory Locale_Code

section ‹Code Generation from Locales›
theory Locale_Code
  imports ICF_Tools Ord_Code_Preproc
begin

text ‹
  Provides a simple mechanism to prepare code equations for
  constants stemming from locale interpretations.

  The usage pattern is as follows:
    setup Locale_Code.checkpoint› is called before a series of
      interpretations, and afterwards, setup Locale_Code.prepare›
      is called. Afterwards, the code generator will correctly recognize 
      expressions involving terms from the locale interpretation.

›

text ‹Tag to indicate pattern deletion›
definition LC_DEL :: "'a  unit" where "LC_DEL a  ()"

ML signature LOCALE_CODE = sig
  type pat_eq = cterm * thm list

  val open_block: theory -> theory
  val close_block: theory -> theory

  val del_pat: cterm -> theory -> theory
  val add_pat_eq: cterm -> thm list -> theory -> theory

  val lc_decl_eq: thm list -> local_theory -> local_theory
  val lc_decl_del: term -> local_theory -> local_theory

  val setup: theory -> theory

  val get_unf_ss: theory -> simpset

  val tracing_enabled: bool Unsynchronized.ref

end

structure Locale_Code :LOCALE_CODE = struct
  open ICF_Tools

  val tracing_enabled = Unsynchronized.ref false;

  type pat_eq = cterm * thm list

  type block_data = {idx:int, del_pats: cterm list, add_pateqs: pat_eq list}
  val closed_block = {idx = ~1, del_pats=[], add_pateqs=[]};
  fun init_block idx = {idx = idx, del_pats=[], add_pateqs=[]};
  fun is_open ({idx,...}:block_data) = idx <> ~1;

  fun assert_open bd 
  = if is_open bd then () else error "Locale_Code: No open block";

  fun assert_closed bd 
  = if is_open bd then error "Locale_Code: Block already open" else ();


  fun merge_bd (bd1,bd2) = (
    if is_open bd1 orelse is_open bd2 then 
      error "Locale_Code: Merge with open block"  
    else ();
    closed_block
  );

  fun bd_add_del_pats ps {idx,del_pats,add_pateqs} 
    = {idx = idx, del_pats = ps@del_pats, add_pateqs = add_pateqs};
  fun bd_add_add_pateqs pes {idx,del_pats,add_pateqs} 
    = {idx = idx, del_pats = del_pats, add_pateqs = pes@add_pateqs};

  structure BlockData = Theory_Data (
    type T = block_data
    val empty = (closed_block)
    val extend = I
    val merge = merge_bd
  );

  structure FoldSSData = Oc_Simpset (
    val prio = 5;
    val name = "Locale_Code";
  );

  fun add_unf_thms thms thy = let
    val ctxt = Proof_Context.init_global thy
    val thms = map Thm.symmetric thms
  in 
    FoldSSData.map (fn ss => 
         put_simpset ss ctxt 
      |> sss_add thms
      |> simpset_of
    ) thy
  end
  
  val get_unf_ss = FoldSSData.get;


  (* First order match with fixed head *)
  fun match_fixed_head (pat,obj) = let
    (* Match heads *)
    val inst = Thm.first_order_match (chead_of pat, chead_of obj);
    val pat = Thm.instantiate_cterm inst pat;
    (* Now match whole pattern *)
    val inst = Thm.first_order_match (pat, obj);
  in inst end;

  val matches_fixed_head = can match_fixed_head; 

  (* First order match of heads only *)
  fun match_heads (pat,obj) = Thm.first_order_match (chead_of pat, chead_of obj);

  val matches_heads = can match_heads; 

  val pat_nargs = Thm.term_of #> strip_comb #> #2 #> length;

  (* Adjust a theorem to exactly match pattern *)
  fun norm_thm_pat (thm,pat) = let
    val thm = norm_def_thm thm;
    val na_pat = pat_nargs pat;
    val lhs = Thm.lhs_of thm;
    val na_lhs = pat_nargs lhs;
    val lhs' = if na_lhs > na_pat then funpow (na_lhs - na_pat) Thm.dest_fun lhs
      else lhs;
    val inst = Thm.first_order_match (lhs',pat);
  in Thm.instantiate inst thm end;

  fun del_pat_matches cpat (epat,_) = if pat_nargs cpat = 0 then
    matches_heads (cpat,epat)
  else
    matches_fixed_head (cpat,epat);

  (* Pattern-Eqs from specification *)
  local
    datatype action = ADD of (cterm * thm list) 
    | DEL of cterm

    fun filter_pat_eq thy thms pat = let
      val cpat = Thm.global_cterm_of thy pat;
    in 
      if (pat_nargs cpat = 0) then NONE
      else let 
        val thms' = fold 
          (fn thm => fn acc => case try norm_thm_pat (thm, cpat) of
            NONE => acc | SOME thm => thm::acc
          ) thms [];
      in case thms' of [] => NONE | _ => SOME (ADD (cpat,thms')) end 
    end;

    fun process_actions acc [] = acc
    | process_actions acc (ADD peq::acts) = process_actions (peq::acc) acts
    | process_actions acc (DEL cpat::acts) = let
      val acc' = filter (not o curry renames_cterm cpat o fst) acc;
      val _ = if length acc = length acc' then
          warning ("Locale_Code: LC_DEL without effect: "
            ^ @{make_string} cpat) 
        else ();
    in process_actions acc' acts end;

    fun pat_eqs_of_spec thy
          {rough_classification = Spec_Rules.Equational _, terms = pats, rules = thms, ...} =
        map_filter (filter_pat_eq thy thms) pats
    | pat_eqs_of_spec thy
          {rough_classification = Spec_Rules.Unknown, terms = [Const (@{const_name LC_DEL},_)$pat], ...} =
        [(DEL (Thm.global_cterm_of thy pat))]
    | pat_eqs_of_spec _ _ = [];
  in

    fun pat_eqs_of_specs thy specs = map (pat_eqs_of_spec thy) specs 
      |> flat |> rev |> process_actions [];
  
  end;

  
  fun is_proper_pat cpat = let
    val pat = Thm.term_of cpat;
    val (f,args) = strip_comb pat;
  in 
    is_Const f 
    andalso args <> [] 
    andalso not (is_Var (hd (rev args)))
  end;

  (* Instantiating pattern-eq *)
  local
    (* Get constant name for instantiation pattern *)
    fun inst_name lthy pat = let
      val (fname,params) = case strip_comb pat of
        ((Const (fname,_)),params) => (fname,params)
      | _ => raise TERM ("inst_name: Expected pattern",[pat]);

      fun pname (Const (n,_)) = Long_Name.base_name n
        | pname (s$t) = pname s ^ "_" ^ pname t
        | pname _ = Name.uu;
    in  
      space_implode "_" (Long_Name.base_name fname::map pname params)
      |> gen_variant (can (Proof_Context.read_const {proper = true, strict = false} lthy))
    end;
  in
    fun inst_pat_eq (cpat,thms) = 
    wrap_lthy_result_global
      (fn lthy => let
        val ((inst,thms),lthy) = Variable.import true thms lthy;
        val cpat = Thm.instantiate_cterm inst cpat;
        val pat = Thm.term_of cpat;
        val name = inst_name lthy pat;
        val ((_,(_,def_thm)),lthy) 
          = Local_Theory.define ((Binding.name name,NoSyn),
             ((Binding.name (Thm.def_name name),[]),pat)) lthy;
        val thms' = map (Local_Defs.fold lthy [def_thm]) thms;
      in ((def_thm,thms'),lthy) end)
      (fn m => fn (def_thm,thms') => 
        (Morphism.thm m def_thm, map (Morphism.thm m) thms'))
    #> (fn ((def_thm,thms'),thy) => let
      val thy = thy 
        |> add_unf_thms [def_thm]
        |> Code.declare_default_eqns_global (map (rpair true) thms');
    in thy end)
  end

  (* Bookkeeping *)
  fun new_specs thy = let
    val bd = BlockData.get thy;
    val _ = assert_open bd;
    val ctxt = Proof_Context.init_global thy;
    val srules = Spec_Rules.get ctxt;
    val res = take (length srules - #idx bd) srules;
  in res end

  fun open_block thy = let
    val bd = BlockData.get thy;
    val _ = assert_closed bd;
    val ctxt = Proof_Context.init_global thy;
    val idx = length (Spec_Rules.get ctxt);
    val thy = BlockData.map (K (init_block idx)) thy;
  in thy end;

  fun process_block bd thy = let
    fun filter_del_pats cpat peqs = let
      val peqs' = filter (not o del_pat_matches cpat) peqs
      val _ = if length peqs = length peqs' then
          warning ("Locale_Code: No pattern-eqs matching filter: " ^ 
            @{make_string} cpat) 
        else ();
    in peqs' end;

    fun filter_add_pats (orig_pat,_) = forall (fn (add_pat,_) => 
        not (renames_cterm (orig_pat,add_pat))) 
      (#add_pateqs bd);

    val specs = new_specs thy;
    val peqs = pat_eqs_of_specs thy specs
      |> fold filter_del_pats (#del_pats bd)
      |> filter filter_add_pats;
    val peqs = peqs @ #add_pateqs bd;

    val peqs = rev peqs; (* Important: Process equations in the order in that
      they have been added! *)

    val _ = if !tracing_enabled then
      map (fn peq => (tracing (@{make_string} peq); ())) peqs
    else [];

    val thy = thy |> fold inst_pat_eq peqs;

  in thy end;

  fun close_block thy = let
    val bd = BlockData.get thy;
    val _ = assert_open bd;
    val thy = process_block bd thy
      |> BlockData.map (K closed_block);
  in thy end;
    

  fun del_pat cpat thy = let
    val bd = BlockData.get thy;
    val _ = assert_open bd;
    val bd = bd_add_del_pats [cpat] bd;
    val thy = BlockData.map (K bd) thy;
  in thy end;

  fun add_pat_eq cpat thms thy = let
    val _ = is_proper_pat cpat 
      orelse raise CTERM ("add_pat_eq: Not a proper pattern",[cpat]);
  
    fun ntp thm = case try norm_thm_pat (thm,cpat) of
      NONE => raise THM ("add_pat_eq: Theorem does not match pattern",~1,[thm])
    | SOME thm => thm;
  
    val thms = map ntp thms;
    val thy = BlockData.map (bd_add_add_pateqs [(cpat,thms)]) thy;
  in thy end;

  local
    fun cpat_of_thm thm = let
      fun strip ct = case Thm.term_of ct of
        (_$Var _) => strip (Thm.dest_fun ct)
      | _ => ct;
    in
      strip (Thm.lhs_of thm)
    end;

    fun adjust_length (cpat1,cpat2) = let
      val n1 = cpat1 |> Thm.term_of |> strip_comb |> #2 |> length;
      val n2 = cpat2 |> Thm.term_of |> strip_comb |> #2 |> length;
    in 
      if n1>n2 then
        (funpow (n1-n2) Thm.dest_fun cpat1, cpat2)
      else
        (cpat1, funpow (n2-n1) Thm.dest_fun cpat2)

    end

    fun find_match cpat cpat' = SOME (cpat,rename_cterm (cpat',cpat))
      handle Pattern.MATCH => (case Thm.term_of cpat' of 
          _$_ => find_match (Thm.dest_fun cpat) (Thm.dest_fun cpat')
        | _ => NONE
      );

    (* Common head of definitional theorems *)
    fun comp_head thms = case map norm_def_thm thms of
      [] => NONE
    | thm::thms => let
        fun ch [] r = SOME r
        | ch (thm::thms) (cpat,acc) = let
            val cpat' = cpat_of_thm thm;
            val (cpat,cpat') = adjust_length (cpat,cpat')
          in case find_match cpat cpat' of NONE => NONE
            | SOME (cpat,inst) => 
              ch thms (cpat, Drule.instantiate_normalize inst thm :: acc)
          end;
      in ch thms (cpat_of_thm thm,[thm]) end;

  in
    fun lc_decl_eq thms lthy = case comp_head thms of
      SOME (cpat,thms) => let
        val _ = if !tracing_enabled then 
          tracing ("decl_eq: " ^ @{make_string} cpat ^ ": "
                 ^ @{make_string} thms)
        else ();

        fun decl m = let
          val cpat'::thms' = Morphism.fact m (Drule.mk_term cpat :: thms);
          val cpat' = Drule.dest_term cpat';
        in 
          Context.mapping 
            (BlockData.map (bd_add_add_pateqs [(cpat',thms')])) I 
        end
      in 
        lthy |> Local_Theory.declaration {syntax = false, pervasive = false} decl
      end
    | NONE => raise THM ("Locale_Code.lc_decl_eq: No common pattern",~1,thms);

  end;

  fun lc_decl_del pat = let
    val ty = fastype_of pat;
    val dpat = Const (@{const_name LC_DEL},ty --> @{typ unit})$pat;
  in 
    Spec_Rules.add Binding.empty Spec_Rules.Unknown [dpat] []
  end


  (* Package setup *)
  val setup = FoldSSData.setup;

end

setup Locale_Code.setup

attribute_setup lc_delete = ‹
  Parse.and_list1' ICF_Tools.parse_cpat >> 
    (fn cpats => Thm.declaration_attribute (K 
      (Context.mapping (fold Locale_Code.del_pat cpats) I))) "Locale_Code: Delete patterns for current block"

attribute_setup lc_add = ‹
  Parse.and_list1' (ICF_Tools.parse_cpat -- Attrib.thms) >> 
    (fn peqs => Thm.declaration_attribute (K 
      (Context.mapping (fold (uncurry Locale_Code.add_pat_eq) peqs) I))) "Locale_Code: Add pattern-eqs for current block"

end

Theory ICF_Spec_Base

theory ICF_Spec_Base
imports
  "../../Iterator/Iterator"
  "../tools/Record_Intf" 
  "../tools/Locale_Code" 
begin

end

Theory MapSpec

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Specification of Maps}›
theory MapSpec
imports ICF_Spec_Base
begin
text_raw‹\label{thy:MapSpec}›

(*@intf Map
  @abstype 'k⇀'v
  This interface specifies maps from keys to values.
*)

text ‹
  This theory specifies map operations by means of mapping to
  HOL's map type, i.e. @{typ "'k  'v"}.
›

type_synonym ('k,'v,'s) map_α = "'s  'k  'v"
type_synonym ('k,'v,'s) map_invar = "'s  bool"
locale map = 
  fixes α :: "'s  'u  'v"                 ― ‹Abstraction to map datatype›
  fixes invar :: "'s  bool"                 ― ‹Invariant›

locale map_no_invar = map +
  assumes invar[simp, intro!]: "s. invar s"

subsection "Basic Map Functions"

subsubsection "Empty Map"
type_synonym ('k,'v,'s) map_empty = "unit  's"
locale map_empty = map +
  constrains α :: "'s  'u  'v"
  fixes empty :: "unit  's"
  assumes empty_correct:
    "α (empty ()) = Map.empty"
    "invar (empty ())"

subsubsection "Lookup"
type_synonym ('k,'v,'s) map_lookup = "'k  's  'v option"
locale map_lookup = map +
  constrains α :: "'s  'u  'v"
  fixes lookup :: "'u  's  'v option"
  assumes lookup_correct:
    "invar m  lookup k m = α m k"

subsubsection "Update"
type_synonym ('k,'v,'s) map_update = "'k  'v  's  's"
locale map_update = map +
  constrains α :: "'s  'u  'v"
  fixes update :: "'u  'v  's  's"
  assumes update_correct:
    "invar m  α (update k v m) = (α m)(k  v)"
    "invar m  invar (update k v m)"

subsubsection "Disjoint Update"
type_synonym ('k,'v,'s) map_update_dj = "'k  'v  's  's"
locale map_update_dj = map +
  constrains α :: "'s  'u  'v"
  fixes update_dj :: "'u  'v  's  's"
  assumes update_dj_correct: 
    "invar m; kdom (α m)  α (update_dj k v m) = (α m)(k  v)"
    "invar m; kdom (α m)  invar (update_dj k v m)"

 
subsubsection "Delete"
type_synonym ('k,'v,'s) map_delete = "'k  's  's"
locale map_delete = map +
  constrains α :: "'s  'u  'v"
  fixes delete :: "'u  's  's"
  assumes delete_correct: 
    "invar m  α (delete k m) = (α m) |` (-{k})"
    "invar m  invar (delete k m)"

subsubsection "Add"
type_synonym ('k,'v,'s) map_add = "'s  's  's"
locale map_add = map +
  constrains α :: "'s  'u  'v"
  fixes add :: "'s  's  's"
  assumes add_correct:
    "invar m1  invar m2  α (add m1 m2) = α m1 ++ α m2"
    "invar m1  invar m2  invar (add m1 m2)"

type_synonym ('k,'v,'s) map_add_dj = "'s  's  's"
locale map_add_dj = map +
  constrains α :: "'s  'u  'v"
  fixes add_dj :: "'s  's  's"
  assumes add_dj_correct:
    "invar m1; invar m2; dom (α m1)  dom (α m2) = {}  α (add_dj m1 m2) = α m1 ++ α m2"
    "invar m1; invar m2; dom (α m1)  dom (α m2) = {}   invar (add_dj m1 m2)"

subsubsection "Emptiness Check"
type_synonym ('k,'v,'s) map_isEmpty = "'s  bool"
locale map_isEmpty = map +
  constrains α :: "'s  'u  'v"
  fixes isEmpty :: "'s  bool"
  assumes isEmpty_correct : "invar m  isEmpty m  α m = Map.empty"

subsubsection "Singleton Maps"
type_synonym ('k,'v,'s) map_sng = "'k  'v  's"
locale map_sng = map +
  constrains α :: "'s  'u  'v"
  fixes sng :: "'u  'v  's"
  assumes sng_correct : 
    "α (sng k v) = [k  v]"
    "invar (sng k v)"

type_synonym ('k,'v,'s) map_isSng = "'s  bool"
locale map_isSng = map +
  constrains α :: "'s  'k  'v"
  fixes isSng :: "'s  bool"
  assumes isSng_correct:
    "invar s  isSng s  (k v. α s = [k  v])"
begin
  lemma isSng_correct_exists1 :
    "invar s  (isSng s  (∃!k. v. (α s k = Some v)))"
    apply (auto simp add: isSng_correct split: if_split_asm)
    apply (rule_tac x=k in exI)
    apply (rule_tac x=v in exI)
    apply (rule ext)
    apply (case_tac "α s x")
    apply auto
    apply force
    done

  lemma isSng_correct_card :
    "invar s  (isSng s  (card (dom (α s)) = 1))"
    by (auto simp add: isSng_correct card_Suc_eq dom_eq_singleton_conv)

end

subsubsection "Finite Maps"
locale finite_map = map +
  assumes finite[simp, intro!]: "invar m  finite (dom (α m))"

subsubsection "Size"
type_synonym ('k,'v,'s) map_size = "'s  nat"
locale map_size = finite_map +
  constrains α :: "'s  'u  'v"
  fixes size :: "'s  nat"
  assumes size_correct: "invar s  size s = card (dom (α s))"
  
type_synonym ('k,'v,'s) map_size_abort = "nat  's  nat"
locale map_size_abort = finite_map +
  constrains α :: "'s  'u  'v"
  fixes size_abort :: "nat  's  nat"
  assumes size_abort_correct: "invar s  size_abort m s = min m (card (dom (α s)))"

subsubsection "Iterators"
text ‹
  An iteration combinator over a map applies a function to a state for each 
  map entry, in arbitrary order.
  Proving of properties is done by invariant reasoning.
  An iterator can also contain a continuation condition. Iteration is
  interrupted if the condition becomes false.
›

(* Deprecated *)
(*locale map_iteratei = finite_map +
  constrains α :: "'s ⇒ 'u ⇀ 'v"
  fixes iteratei :: "'s ⇒ ('u × 'v,'σ) set_iterator"

  assumes iteratei_rule: "invar m ⟹ map_iterator (iteratei m) (α m)"
begin
  lemma iteratei_rule_P:
    assumes "invar m"
        and I0: "I (dom (α m)) σ0"
        and IP: "!!k v it σ. ⟦ c σ; k ∈ it; α m k = Some v; it ⊆ dom (α m); I it σ ⟧ 
                    ⟹ I (it - {k}) (f (k, v) σ)"
        and IF: "!!σ. I {} σ ⟹ P σ"
        and II: "!!σ it. ⟦ it ⊆ dom (α m); it ≠ {}; ¬ c σ; I it σ ⟧ ⟹ P σ"
    shows "P (iteratei m c f σ0)"
    using map_iterator_rule_P [OF iteratei_rule, of m I σ0 c f P]
    by (simp_all add: assms)

  lemma iteratei_rule_insert_P:
    assumes  
      "invar m" 
      "I {} σ0"
      "!!k v it σ. ⟦ c σ; k ∈ (dom (α m) - it); α m k = Some v; it ⊆ dom (α m); I it σ ⟧ 
          ⟹ I (insert k it) (f (k, v) σ)"
      "!!σ. I (dom (α m)) σ ⟹ P σ"
      "!!σ it. ⟦ it ⊆ dom (α m); it ≠ dom (α m); 
               ¬ (c σ); 
               I it σ ⟧ ⟹ P σ"
    shows "P (iteratei m c f σ0)"
    using map_iterator_rule_insert_P [OF iteratei_rule, of m I σ0 c f P]
    by (simp_all add: assms)

  lemma iterate_rule_P:
    "⟦
      invar m;
      I (dom (α m)) σ0;
      !!k v it σ. ⟦ k ∈ it; α m k = Some v; it ⊆ dom (α m); I it σ ⟧ 
                  ⟹ I (it - {k}) (f (k, v) σ);
      !!σ. I {} σ ⟹ P σ
    ⟧ ⟹ P (iteratei m (λ_. True) f σ0)"
    using iteratei_rule_P [of m I σ0 "λ_. True" f P]
    by fast

  lemma iterate_rule_insert_P:
    "⟦
      invar m;
      I {} σ0;
      !!k v it σ. ⟦ k ∈ (dom (α m) - it); α m k = Some v; it ⊆ dom (α m); I it σ ⟧ 
                  ⟹ I (insert k it) (f (k, v) σ);
      !!σ. I (dom (α m)) σ ⟹ P σ
    ⟧ ⟹ P (iteratei m (λ_. True) f σ0)"
    using iteratei_rule_insert_P [of m I σ0 "λ_. True" f P]
    by fast
end

lemma map_iteratei_I :
  assumes "⋀m. invar m ⟹ map_iterator (iti m) (α m)"
  shows "map_iteratei α invar iti"
proof
  fix m 
  assume invar_m: "invar m"
  from assms(1)[OF invar_m] show it_OK: "map_iterator (iti m) (α m)" .
  
  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (dom (α m))" by (simp add: finite_map_to_set) 
qed
*)

type_synonym ('k,'v,'s) map_list_it
  = "'s  ('k×'v,('k×'v) list) set_iterator"
locale poly_map_iteratei_defs =
  fixes list_it :: "'s  ('u×'v,('u×'v) list) set_iterator"
begin
  definition iteratei :: "'s  ('u×'v,) set_iterator"
    where "iteratei S  it_to_it (list_it S)"

  abbreviation "iterate m  iteratei m (λ_. True)"
end

locale poly_map_iteratei =
  finite_map + poly_map_iteratei_defs list_it
  for list_it :: "'s  ('u×'v,('u×'v) list) set_iterator" +
  constrains α :: "'s  'u  'v"
  assumes list_it_correct: "invar m  map_iterator (list_it m) (α m)"
begin
  lemma iteratei_correct: "invar S  map_iterator (iteratei S) (α S)"
    unfolding iteratei_def
    apply (rule it_to_it_correct)
    by (rule list_it_correct)

  lemma pi_iteratei[icf_proper_iteratorI]: 
    "proper_it (iteratei S) (iteratei S)"
    unfolding iteratei_def 
    by (intro icf_proper_iteratorI)

  lemma iteratei_rule_P:
    assumes "invar m"
    and I0: "I (map_to_set (α m)) σ0"
    and IP: "!!k v it σ.  c σ; (k,v)  it; it  map_to_set (α m); I it σ  
       I (it - {(k,v)}) (f (k, v) σ)"
    and IF: "!!σ. I {} σ  P σ"
    and II: "!!σ it.  it  map_to_set (α m); it  {}; ¬ c σ; I it σ   P σ"
    shows "P (iteratei m c f σ0)"
    apply (rule set_iterator_rule_P[OF iteratei_correct])
    apply fact
    apply fact
    apply (case_tac x, simp add: IP)
    apply fact
    apply fact
    done

  lemma iteratei_rule_insert_P:
    assumes "invar m" 
    and "I {} σ0"
    and "!!k v it σ.  c σ; (k,v)  (map_to_set (α m) - it); 
                       it  map_to_set (α m); I it σ  
       I (insert (k,v) it) (f (k, v) σ)"
    and "!!σ. I (map_to_set (α m)) σ  P σ"
    and "!!σ it.  it  map_to_set (α m); it  map_to_set (α m); 
                  ¬ (c σ); 
                  I it σ   P σ"
    shows "P (iteratei m c f σ0)"
    apply (rule set_iterator_rule_insert_P[OF iteratei_correct])
    apply fact
    apply fact
    apply (case_tac x, simp add: assms)
    apply fact
    apply fact
    done

  lemma iterate_rule_P:
    assumes "invar m"
    and I0: "I (map_to_set (α m)) σ0"
    and IP: "!!k v it σ.  (k,v)  it; it  map_to_set (α m); I it σ  
       I (it - {(k,v)}) (f (k, v) σ)"
    and IF: "!!σ. I {} σ  P σ"
    shows "P (iterate m f σ0)"
    apply (rule iteratei_rule_P)
    apply fact
    apply (rule I0)
    apply (rule IP, assumption+) []
    apply (rule IF, assumption)
    apply simp
    done

  lemma iterate_rule_insert_P:
    assumes "invar m" 
    and I0: "I {} σ0"
    and "!!k v it σ.  (k,v)  (map_to_set (α m) - it); 
                       it  map_to_set (α m); I it σ  
       I (insert (k,v) it) (f (k, v) σ)"
    and "!!σ. I (map_to_set (α m)) σ  P σ"
    shows "P (iterate m f σ0)"
    apply (rule iteratei_rule_insert_P)
    apply fact
    apply (rule I0)
    apply (rule assms, assumption+) []
    apply (rule assms, assumption)
    apply simp
    done
    
  lemma old_iteratei_rule_P:
    assumes "invar m"
    and I0: "I (dom (α m)) σ0"
    and IP: "!!k v it σ.  c σ; k  it; α m k = Some v; it  dom (α m); I it σ  
       I (it - {k}) (f (k, v) σ)"
    and IF: "!!σ. I {} σ  P σ"
    and II: "!!σ it.  it  dom (α m); it  {}; ¬ c σ; I it σ   P σ"
    shows "P (iteratei m c f σ0)"
    using assms
    by (rule map_iterator_rule_P[OF iteratei_correct])

  lemma old_iteratei_rule_insert_P:
    assumes "invar m" 
    and "I {} σ0"
    and "!!k v it σ.  c σ; k  (dom (α m) - it); α m k = Some v; 
                       it  dom (α m); I it σ  
       I (insert k it) (f (k, v) σ)"
    and "!!σ. I (dom (α m)) σ  P σ"
    and "!!σ it.  it  dom (α m); it  dom (α m); 
                  ¬ (c σ); 
                  I it σ   P σ"
    shows "P (iteratei m c f σ0)"
    using assms by (rule map_iterator_rule_insert_P[OF iteratei_correct])

  lemma old_iterate_rule_P:
    "
      invar m;
      I (dom (α m)) σ0;
      !!k v it σ.  k  it; α m k = Some v; it  dom (α m); I it σ  
                   I (it - {k}) (f (k, v) σ);
      !!σ. I {} σ  P σ
      P (iterate m f σ0)"
    using old_iteratei_rule_P [of m I σ0 "λ_. True" f P]
    by blast

  lemma old_iterate_rule_insert_P:
    "
      invar m;
      I {} σ0;
      !!k v it σ.  k  (dom (α m) - it); α m k = Some v; 
                    it  dom (α m); I it σ  
                   I (insert k it) (f (k, v) σ);
      !!σ. I (dom (α m)) σ  P σ
      P (iteratei m (λ_. True) f σ0)"
    using old_iteratei_rule_insert_P [of m I σ0 "λ_. True" f P]
    by blast

  end


subsubsection "Bounded Quantification"
type_synonym ('k,'v,'s) map_ball = "'s  ('k × 'v  bool)  bool"
locale map_ball = map +
  constrains α :: "'s  'u  'v"
  fixes ball :: "'s  ('u × 'v  bool)  bool"
  assumes ball_correct: "invar m  ball m P  (u v. α m u = Some v  P (u, v))"

type_synonym ('k,'v,'s) map_bex = "'s  ('k × 'v  bool)  bool"
locale map_bex = map +
  constrains α :: "'s  'u  'v"
  fixes bex :: "'s  ('u × 'v  bool)  bool"
  assumes bex_correct: 
    "invar m  bex m P  (u v. α m u = Some v  P (u, v))"


subsubsection "Selection of Entry"
type_synonym ('k,'v,'s,'r) map_sel = "'s  ('k × 'v  'r option)  'r option"
locale map_sel = map +
  constrains α :: "'s  'u  'v"
  fixes sel :: "'s  ('u × 'v  'r option)  'r option"
  assumes selE: 
  " invar m; α m u = Some v; f (u, v) = Some r; 
     !!u v r.  sel m f = Some r; α m u = Some v; f (u, v) = Some r   Q 
     Q"
  assumes selI: 
    " invar m; u v. α m u = Some v  f (u, v) = None   sel m f = None"

begin
  lemma sel_someE: 
    " invar m; sel m f = Some r; 
       !!u v.  α m u = Some v; f (u, v) = Some r   P
       P"
    apply (cases "u v r. α m u = Some v  f (u, v) = Some r")
    apply safe
    apply (erule_tac u=u and v=v and r=ra in selE)
    apply assumption
    apply assumption
    apply simp
    apply (auto)
    apply (drule (1) selI)
    apply simp
    done

  lemma sel_noneD: "invar m; sel m f = None; α m u = Some v  f (u, v) = None"
    apply (rule ccontr)
    apply simp
    apply (erule exE)
    apply (erule_tac f=f and u=u and v=v and r=y in selE)
    apply auto
    done

end

  ― ‹Equivalent description of sel-map properties›
lemma map_sel_altI:
  assumes S1: 
    "!!s f r P.  invar s; sel s f = Some r; 
                  !!u v. α s u = Some v; f (u, v) = Some r  P
                  P"
  assumes S2: 
    "!!s f u v. invar s; sel s f = None; α s u = Some v  f (u, v) = None"
  shows "map_sel α invar sel"
proof -
  show ?thesis
    apply (unfold_locales)
    apply (case_tac "sel m f")
    apply (force dest: S2)
    apply (force elim: S1)
    apply (case_tac "sel m f")
    apply assumption
    apply (force elim: S1)
    done
qed


subsubsection "Selection of Entry (without mapping)"
type_synonym ('k,'v,'s) map_sel' = "'s  ('k × 'v  bool)  ('k×'v) option"
locale map_sel' = map +
  constrains α :: "'s  'u  'v"
  fixes sel' :: "'s  ('u × 'v  bool)  ('u×'v) option"
  assumes sel'E: 
  " invar m; α m u = Some v; P (u, v); 
     !!u v.  sel' m P = Some (u,v); α m u = Some v; P (u, v)  Q 
     Q"
  assumes sel'I: 
    " invar m; u v. α m u = Some v  ¬ P (u, v)   sel' m P = None"

begin
  lemma sel'_someE: 
    " invar m; sel' m P = Some (u,v); 
       !!u v.  α m u = Some v; P (u, v)   thesis
       thesis"
    apply (cases "u v. α m u = Some v  P (u, v)")
    apply safe
    apply (erule_tac u=ua and v=va in sel'E)
    apply assumption
    apply assumption
    apply simp
    apply (auto)
    apply (drule (1) sel'I)
    apply simp
    done

  lemma sel'_noneD: "invar m; sel' m P = None; α m u = Some v  ¬ P (u, v)"
    apply (rule ccontr)
    apply simp
    apply (erule (2) sel'E[where P=P])
    apply auto
    done

  lemma sel'_SomeD:
    " sel' m P = Some (u, v); invar m   α m u = Some v  P (u, v)"
    apply(cases "u' v'. α m u' = Some v'  P (u', v')")
     apply clarsimp
     apply(erule (2) sel'E[where P=P])
     apply simp
    apply(clarsimp)
    apply(drule (1) sel'I)
    apply simp
    done
end

subsubsection "Map to List Conversion"
type_synonym ('k,'v,'s) map_to_list = "'s  ('k×'v) list"
locale map_to_list = map +
  constrains α :: "'s  'u  'v"
  fixes to_list :: "'s  ('u×'v) list"
  assumes to_list_correct: 
    "invar m  map_of (to_list m) = α m"
    "invar m  distinct (map fst (to_list m))"


subsubsection "List to Map Conversion"
type_synonym ('k,'v,'s) list_to_map = "('k×'v) list  's"
locale list_to_map = map +
  constrains α :: "'s  'u  'v"
  fixes to_map :: "('u×'v) list  's"
  assumes to_map_correct:
    "α (to_map l) = map_of l"
    "invar (to_map l)"

subsubsection "Image of a Map"

text ‹This locale allows to apply a function to both the keys and
 the values of a map while at the same time filtering entries.›

definition transforms_to_unique_keys ::
  "('u1  'v1)  ('u1 × 'v1  ('u2 × 'v2))  bool"
  where
  "transforms_to_unique_keys m f  (k1 k2 v1 v2 k' v1' v2'. ( 
         m k1 = Some v1 
         m k2 = Some v2 
         f (k1, v1) = Some (k', v1') 
         f (k2, v2) = Some (k', v2')) -->
       (k1 = k2))"

type_synonym ('k1,'v1,'m1,'k2,'v2,'m2) map_image_filter  
  = "('k1 × 'v1  ('k2 × 'v2) option)  'm1  'm2"

locale map_image_filter = m1: map α1 invar1 + m2: map α2 invar2
  for α1 :: "'m1  'u1  'v1" and invar1
  and α2 :: "'m2  'u2  'v2" and invar2
  +
  fixes map_image_filter :: "('u1 × 'v1  ('u2 × 'v2) option)  'm1  'm2"
  assumes map_image_filter_correct_aux1:
    "k' v'. 
     invar1 m; transforms_to_unique_keys (α1 m) f  
     (invar2 (map_image_filter f m) 
      ((α2 (map_image_filter f m) k' = Some v') 
       (k v. (α1 m k = Some v)  f (k, v) = Some (k', v'))))"
begin

  (*Let's use a definition for the precondition *)

  lemma map_image_filter_correct_aux2 :
    assumes "invar1 m" 
      and "transforms_to_unique_keys (α1 m) f"
    shows "(α2 (map_image_filter f m) k' = None) 
      (k v v'. α1 m k = Some v  f (k, v)  Some (k', v'))"
  proof -
    note map_image_filter_correct_aux1 [OF assms]
    have Some_eq: "v'. (α2 (map_image_filter f m) k' = Some v') =
          (k v. α1 m k = Some v  f (k, v) = Some (k', v'))"
      by (simp add: map_image_filter_correct_aux1 [OF assms])
    
    have intro_some: "(α2 (map_image_filter f m) k' = None) 
                      (v'. α2 (map_image_filter f m) k'  Some v')" by auto
    
    from intro_some Some_eq show ?thesis by auto
  qed

  lemmas map_image_filter_correct = 
     conjunct1 [OF map_image_filter_correct_aux1] 
     conjunct2 [OF map_image_filter_correct_aux1] 
     map_image_filter_correct_aux2
end
    

text ‹Most of the time the mapping function is only applied to values. Then,
  the precondition disapears.›
type_synonym ('k,'v1,'m1,'k2,'v2,'m2) map_value_image_filter  
  = "('k  'v1  'v2 option)  'm1  'm2"

locale map_value_image_filter = m1: map α1 invar1 + m2: map α2 invar2
  for α1 :: "'m1  'u  'v1" and invar1
  and α2 :: "'m2  'u  'v2" and invar2
  +
  fixes map_value_image_filter :: "('u  'v1  'v2 option)  'm1  'm2"
  assumes map_value_image_filter_correct_aux:
    "invar1 m  
     invar2 (map_value_image_filter f m) 
     (α2 (map_value_image_filter f m) = 
      (λk. Option.bind (α1 m k) (f k)))"
begin

  lemmas map_value_image_filter_correct =
    conjunct1[OF map_value_image_filter_correct_aux]
    conjunct2[OF map_value_image_filter_correct_aux]


  lemma map_value_image_filter_correct_alt :
    "invar1 m  
     invar2 (map_value_image_filter f m)"
    "invar1 m 
     (α2 (map_value_image_filter f m) k = Some v') 
     (v. (α1 m k = Some v)  f k v = Some v')"
    "invar1 m 
     (α2 (map_value_image_filter f m) k = None) 
     (v. (α1 m k = Some v) --> f k v = None)"
  proof -
    assume invar_m : "invar1 m"
    note aux = map_value_image_filter_correct_aux [OF invar_m]

    from aux show "invar2 (map_value_image_filter f m)" by simp
    from aux show "(α2 (map_value_image_filter f m) k = Some v') 
     (v. (α1 m k = Some v)  f k v = Some v')" 
      by (cases "α1 m k", simp_all)
    from aux show "(α2 (map_value_image_filter f m) k = None) 
     (v. (α1 m k = Some v) --> f k v = None)" 
      by (cases "α1 m k", simp_all)
  qed
end

type_synonym ('k,'v,'m1,'m2) map_restrict = "('k × 'v  bool)  'm1  'm2"
locale map_restrict = m1: map α1 invar1 + m2: map α2 invar2 
  for α1 :: "'m1  'u  'v" and invar1
  and α2 :: "'m2  'u  'v" and invar2
  +
  fixes restrict :: "('u × 'v  bool)  'm1  'm2"
  assumes restrict_correct_aux1 :
    "invar1 m  α2 (restrict P m) = α1 m |` {k. v. α1 m k = Some v  P (k, v)}"
    "invar1 m  invar2 (restrict P m)"
begin
  lemma restrict_correct_aux2 :
    "invar1 m  α2 (restrict (λ(k,_). P k) m) = α1 m |` {k. P k}"
  proof -
    assume invar_m : "invar1 m"
    have "α1 m |` {k. (v. α1 m k = Some v)  P k} = α1 m |` {k. P k}"
      (is "α1 m |` ?A1 = α1 m |` ?A2")
    proof
      fix k
      show "(α1 m |` ?A1) k = (α1 m |` ?A2) k"
      proof (cases "k  ?A2")
        case False thus ?thesis by simp
      next
        case True
        hence P_k : "P k" by simp

        show ?thesis
          by (cases "α1 m k", simp_all add: P_k)
      qed
    qed
    with invar_m show "α2 (restrict (λ(k, _). P k) m) = α1 m |` {k. P k}"
      by (simp add: restrict_correct_aux1)
  qed

  lemmas restrict_correct = 
     restrict_correct_aux1
     restrict_correct_aux2
end


subsection "Ordered Maps"
  locale ordered_map = map α invar 
    for α :: "'s  ('u::linorder)  'v" and invar

  locale ordered_finite_map = finite_map α invar + ordered_map α invar
    for α :: "'s  ('u::linorder)  'v" and invar

subsubsection ‹Ordered Iteration›
  (* Deprecated *)
(*
  locale map_iterateoi = ordered_finite_map α invar
    for α :: "'s ⇒ ('u::linorder) ⇀ 'v" and invar
    +
    fixes iterateoi :: "'s ⇒ ('u × 'v,'σ) set_iterator"
    assumes iterateoi_rule: "
      invar m ⟹ map_iterator_linord (iterateoi m) (α m)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (α m)) σ0"
      assumes IP: "!!k v it σ. ⟦ 
        c σ; 
        k ∈ it; 
        ∀j∈it. k≤j; 
        ∀j∈dom (α m) - it. j≤k; 
        α m k = Some v; 
        it ⊆ dom (α m); 
        I it σ 
      ⟧ ⟹ I (it - {k}) (f (k, v) σ)"
      assumes IF: "!!σ. I {} σ ⟹ P σ"
      assumes II: "!!σ it. ⟦ 
        it ⊆ dom (α m); 
        it ≠ {}; 
        ¬ c σ; 
        I it σ; 
        ∀k∈it. ∀j∈dom (α m) - it. j≤k 
      ⟧ ⟹ P σ"
      shows "P (iterateoi m c f σ0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I σ0 c f P] assms
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]: 
      assumes MINV: "invar m"
      assumes I0: "I (dom (α m)) σ0"
      assumes IP: "!!k v it σ. ⟦ k ∈ it; ∀j∈it. k≤j; ∀j∈dom (α m) - it. j≤k; α m k = Some v; it ⊆ dom (α m); I it σ ⟧ 
                  ⟹ I (it - {k}) (f (k, v) σ)"
      assumes IF: "!!σ. I {} σ ⟹ P σ"
      shows "P (iterateoi m (λ_. True) f σ0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I σ0 "λ_. True" f P] assms
    by simp
  end

  lemma map_iterateoi_I :
  assumes "⋀m. invar m ⟹ map_iterator_linord (itoi m) (α m)"
  shows "map_iterateoi α invar itoi"
  proof
    fix m 
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_linord (itoi m) (α m)" .
  
    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_linord_def]]
    show "finite (dom (α m))" by (simp add: finite_map_to_set) 
  qed

  locale map_reverse_iterateoi = ordered_finite_map α invar 
    for α :: "'s ⇒ ('u::linorder) ⇀ 'v" and invar
    +
    fixes reverse_iterateoi :: "'s ⇒ ('u × 'v,'σ) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m ⟹ map_iterator_rev_linord (reverse_iterateoi m) (α m)"
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (α m)) σ0"
      assumes IP: "!!k v it σ. ⟦ 
        c σ; 
        k ∈ it; 
        ∀j∈it. k≥j; 
        ∀j∈dom (α m) - it. j≥k; 
        α m k = Some v; 
        it ⊆ dom (α m); 
        I it σ 
      ⟧ ⟹ I (it - {k}) (f (k, v) σ)"
      assumes IF: "!!σ. I {} σ ⟹ P σ"
      assumes II: "!!σ it. ⟦ 
        it ⊆ dom (α m); 
        it ≠ {}; 
        ¬ c σ; 
        I it σ; 
        ∀k∈it. ∀j∈dom (α m) - it. j≥k 
      ⟧ ⟹ P σ"
      shows "P (reverse_iterateoi m c f σ0)"
    using map_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, of m I σ0 c f P] assms
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (α m)) σ0"
      assumes IP: "!!k v it σ. ⟦ 
        k ∈ it; 
        ∀j∈it. k≥j; 
        ∀j∈dom (α m) - it. j≥k; 
        α m k = Some v; 
        it ⊆ dom (α m); 
        I it σ 
      ⟧ ⟹ I (it - {k}) (f (k, v) σ)"
      assumes IF: "!!σ. I {} σ ⟹ P σ"
      shows "P (reverse_iterateoi m (λ_. True) f σ0)"
    using map_iterator_rev_linord_rule_P[OF reverse_iterateoi_rule, of m I σ0 "λ_. True" f P] assms
    by simp
  end

  lemma map_reverse_iterateoi_I :
  assumes "⋀m. invar m ⟹ map_iterator_rev_linord (ritoi m) (α m)"
  shows "map_reverse_iterateoi α invar ritoi"
  proof
    fix m 
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_rev_linord (ritoi m) (α m)" .
  
    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_rev_linord_def]]
    show "finite (dom (α m))" by (simp add: finite_map_to_set) 
  qed
*)

locale poly_map_iterateoi_defs =
  fixes olist_it :: "'s  ('u×'v,('u×'v) list) set_iterator"
begin
  definition iterateoi :: "'s  ('u×'v,) set_iterator"
    where "iterateoi S  it_to_it (olist_it S)"

  abbreviation "iterateo m  iterateoi m (λ_. True)"
end

locale poly_map_iterateoi =
  finite_map α invar + poly_map_iterateoi_defs list_ordered_it
  for α :: "'s  ('u::linorder)  'v" 
  and invar 
  and list_ordered_it :: "'s  ('u×'v,('u×'v) list) set_iterator" +
  assumes list_ordered_it_correct: "invar m 
     map_iterator_linord (list_ordered_it m) (α m)"
begin
  lemma iterateoi_correct: "invar S  map_iterator_linord (iterateoi S) (α S)"
    unfolding iterateoi_def
    apply (rule it_to_it_map_linord_correct)
    by (rule list_ordered_it_correct)

  lemma pi_iterateoi[icf_proper_iteratorI]: 
    "proper_it (iterateoi S) (iterateoi S)"
    unfolding iterateoi_def 
    by (intro icf_proper_iteratorI)


  lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (α m)) σ0"
    assumes IP: "!!k v it σ.  
      c σ; 
      k  it; 
      α m k = Some v; 
      it  dom (α m); 
      I it σ;
      j. jit  kj; 
      j. jdom (α m) - it  jk
      I (it - {k}) (f (k, v) σ)"
    assumes IF: "!!σ. I {} σ  P σ"
    assumes II: "!!σ it.  
      it  dom (α m); 
      it  {}; 
      ¬ c σ; 
      I it σ; 
      k j. kit; jdom (α m) - it  jk 
      P σ"
    shows "P (iterateoi m c f σ0)"
    using assms by (rule map_iterator_linord_rule_P[OF iterateoi_correct])

  lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]: 
    assumes MINV: "invar m"
    assumes I0: "I (dom (α m)) σ0"
    assumes IP: "!!k v it σ.  
      k  it; 
      α m k = Some v; 
      it  dom (α m); 
      I it σ;
      j. jit  kj; 
      j. jdom (α m) - it  jk
      I (it - {k}) (f (k, v) σ)"
    assumes IF: "!!σ. I {} σ  P σ"
    shows "P (iterateo m f σ0)"
    using assms 
      map_iterator_linord_rule_P[OF iterateoi_correct, of m I σ0 "λ_. True" f P]
    by blast

end
  
type_synonym ('k,'v,'s) map_list_rev_it
  = "'s  ('k×'v,('k×'v) list) set_iterator"

locale poly_map_rev_iterateoi_defs =
  fixes list_rev_it :: "'s  ('u×'v,('u×'v) list) set_iterator"
begin
  definition rev_iterateoi :: "'s  ('u×'v,) set_iterator"
    where "rev_iterateoi S  it_to_it (list_rev_it S)"

  abbreviation "rev_iterateo m  rev_iterateoi m (λ_. True)"
  abbreviation "reverse_iterateoi  rev_iterateoi"
  abbreviation "reverse_iterateo  rev_iterateo"
end

locale poly_map_rev_iterateoi =
  finite_map α invar + poly_map_rev_iterateoi_defs list_rev_it
  for α :: "'s  ('u::linorder)  'v" 
  and invar
  and list_rev_it :: "'s  ('u×'v,('u×'v) list) set_iterator" +
  assumes list_rev_it_correct: 
    "invar m  map_iterator_rev_linord (list_rev_it m) (α m)"
begin
  lemma rev_iterateoi_correct: 
    "invar S  map_iterator_rev_linord (rev_iterateoi S) (α S)"
    unfolding rev_iterateoi_def
    apply (rule it_to_it_map_rev_linord_correct)
    by (rule list_rev_it_correct)

  lemma pi_rev_iterateoi[icf_proper_iteratorI]: 
    "proper_it (rev_iterateoi S) (rev_iterateoi S)"
    unfolding rev_iterateoi_def 
    by (intro icf_proper_iteratorI)


  lemma rev_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (α m)) σ0"
    assumes IP: "!!k v it σ.  
      c σ; 
      k  it; 
      α m k = Some v; 
      it  dom (α m); 
      I it σ;
      j. jit  kj; 
      j. jdom (α m) - it  jk
      I (it - {k}) (f (k, v) σ)"
    assumes IF: "!!σ. I {} σ  P σ"
    assumes II: "!!σ it.  
      it  dom (α m); 
      it  {}; 
      ¬ c σ; 
      I it σ; 
      k j. kit; jdom (α m) - it  jk 
      P σ"
    shows "P (rev_iterateoi m c f σ0)"
    using assms by (rule map_iterator_rev_linord_rule_P[OF rev_iterateoi_correct])

  lemma rev_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]: 
    assumes MINV: "invar m"
    assumes I0: "I (dom (α m)) σ0"
    assumes IP: "!!k v it σ.  
      k  it; 
      α m k = Some v; 
      it  dom (α m); 
      I it σ;
      j. jit  kj; 
      j. jdom (α m) - it  jk
      I (it - {k}) (f (k, v) σ)"
    assumes IF: "!!σ. I {} σ  P σ"
    shows "P (rev_iterateo m f σ0)"
    using assms 
      map_iterator_rev_linord_rule_P[OF rev_iterateoi_correct, 
        of m I σ0 "λ_. True" f P]
    by blast

end

subsubsection ‹Minimal and Maximal Elements›

  type_synonym ('k,'v,'s) map_min 
    = "'s  ('k × 'v  bool)  ('k × 'v) option"
  locale map_min = ordered_map +
    constrains α :: "'s  'u::linorder  'v"
    fixes min :: "'s  ('u × 'v  bool)  ('u × 'v) option"
    assumes min_correct:
      " invar s; rel_of (α s) P  {}   min s P  Some ` rel_of (α s) P"
      " invar s; (k,v)  rel_of (α s) P   fst (the (min s P))  k"
      " invar s; rel_of (α s) P = {}   min s P = None"
  begin
   lemma minE: 
     assumes A: "invar s" "rel_of (α s) P  {}"
     obtains k v where
     "min s P = Some (k,v)" "(k,v)rel_of (α s) P" "(k',v')rel_of (α s) P. k  k'"
   proof -
     from min_correct(1)[OF A] have MIS: "min s P  Some ` rel_of (α s) P" .
     then obtain k v where KV: "min s P = Some (k,v)" "(k,v)rel_of (α s) P"
       by auto
     show thesis 
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule min_correct(2)[OF invar s])
       apply (simp add: KV(1))
       done
   qed

   lemmas minI = min_correct(3)

   lemma min_Some:
     " invar s; min s P = Some (k,v)   (k,v)rel_of (α s) P"
     " invar s; min s P = Some (k,v); (k',v')rel_of (α s) P   kk'"
     apply -
     apply (cases "rel_of (α s) P = {}")
     apply (drule (1) min_correct(3))
     apply simp
     apply (erule (1) minE)
     apply auto [1]
     apply (drule (1) min_correct(2))
     apply auto
     done
     
   lemma min_None:
     " invar s; min s P = None   rel_of (α s) P = {}"
     apply (cases "rel_of (α s) P = {}")
     apply simp
     apply (drule (1) min_correct(1))
     apply auto
     done

  end

  type_synonym ('k,'v,'s) map_max
    = "'s  ('k × 'v  bool)  ('k × 'v) option"
  locale map_max = ordered_map +
    constrains α :: "'s  'u::linorder  'v"
    fixes max :: "'s  ('u × 'v  bool)  ('u × 'v) option"
    assumes max_correct:
      " invar s; rel_of (α s) P  {}   max s P  Some ` rel_of (α s) P"
      " invar s; (k,v)  rel_of (α s) P   fst (the (max s P))  k"
      " invar s; rel_of (α s) P = {}   max s P = None"
  begin
   lemma maxE: 
     assumes A: "invar s" "rel_of (α s) P  {}"
     obtains k v where
     "max s P = Some (k,v)" "(k,v)rel_of (α s) P" "(k',v')rel_of (α s) P. k  k'"
   proof -
     from max_correct(1)[OF A] have MIS: "max s P  Some ` rel_of (α s) P" .
     then obtain k v where KV: "max s P = Some (k,v)" "(k,v)rel_of (α s) P"
       by auto
     show thesis 
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule max_correct(2)[OF invar s])
       apply (simp add: KV(1))
       done
   qed

   lemmas maxI = max_correct(3)

   lemma max_Some:
     " invar s; max s P = Some (k,v)   (k,v)rel_of (α s) P"
     " invar s; max s P = Some (k,v); (k',v')rel_of (α s) P   kk'"
     apply -
     apply (cases "rel_of (α s) P = {}")
     apply (drule (1) max_correct(3))
     apply simp
     apply (erule (1) maxE)
     apply auto [1]
     apply (drule (1) max_correct(2))
     apply auto
     done
     
   lemma max_None:
     " invar s; max s P = None   rel_of (α s) P = {}"
     apply (cases "rel_of (α s) P = {}")
     apply simp
     apply (drule (1) max_correct(1))
     apply auto
     done

  end


subsubsection "Conversion to List"
  type_synonym ('k,'v,'s) map_to_sorted_list 
    = "'s  ('k × 'v) list"
  locale map_to_sorted_list = ordered_map +
    constrains α :: "'s  'u::linorder  'v"
    fixes to_sorted_list :: "'s  ('u×'v) list"
    assumes to_sorted_list_correct: 
    "invar m  map_of (to_sorted_list m) = α m"
    "invar m  distinct (map fst (to_sorted_list m))"
    "invar m  sorted (map fst (to_sorted_list m))"

  type_synonym ('k,'v,'s) map_to_rev_list 
    = "'s  ('k × 'v) list"
  locale map_to_rev_list = ordered_map +
    constrains α :: "'s  'u::linorder  'v"
    fixes to_rev_list :: "'s  ('u×'v) list"
    assumes to_rev_list_correct: 
    "invar m  map_of (to_rev_list m) = α m"
    "invar m  distinct (map fst (to_rev_list m))"
    "invar m  sorted (rev (map fst (to_rev_list m)))"

subsection "Record Based Interface"

  record ('k,'v,'s) map_ops = 
    map_op_α :: "('k,'v,'s) map_α"
    map_op_invar :: "('k,'v,'s) map_invar"
    map_op_empty :: "('k,'v,'s) map_empty"
    map_op_lookup :: "('k,'v,'s) map_lookup"
    map_op_update :: "('k,'v,'s) map_update"
    map_op_update_dj :: "('k,'v,'s) map_update_dj"
    map_op_delete :: "('k,'v,'s) map_delete"
    map_op_list_it :: "('k,'v,'s) map_list_it"
    map_op_sng :: "('k,'v,'s) map_sng"
    map_op_restrict :: "('k,'v,'s,'s) map_restrict"
    map_op_add :: "('k,'v,'s) map_add"
    map_op_add_dj :: "('k,'v,'s) map_add_dj"
    map_op_isEmpty :: "('k,'v,'s) map_isEmpty"
    map_op_isSng :: "('k,'v,'s) map_isSng"
    map_op_ball :: "('k,'v,'s) map_ball"
    map_op_bex :: "('k,'v,'s) map_bex"
    map_op_size :: "('k,'v,'s) map_size"
    map_op_size_abort :: "('k,'v,'s) map_size_abort"
    map_op_sel :: "('k,'v,'s) map_sel'"
    map_op_to_list :: "('k,'v,'s) map_to_list"
    map_op_to_map :: "('k,'v,'s) list_to_map"

  locale StdMapDefs = poly_map_iteratei_defs "map_op_list_it ops" 
    for ops :: "('k,'v,'s,'more) map_ops_scheme"
  begin
    abbreviation α where "α == map_op_α ops" 
    abbreviation invar where "invar == map_op_invar ops" 
    abbreviation empty where "empty == map_op_empty ops" 
    abbreviation lookup where "lookup == map_op_lookup ops" 
    abbreviation update where "update == map_op_update ops" 
    abbreviation update_dj where "update_dj == map_op_update_dj ops" 
    abbreviation delete where "delete == map_op_delete ops" 
    abbreviation list_it where "list_it == map_op_list_it ops" 
    abbreviation sng where "sng == map_op_sng ops" 
    abbreviation restrict where "restrict == map_op_restrict ops" 
    abbreviation add where "add == map_op_add ops" 
    abbreviation add_dj where "add_dj == map_op_add_dj ops" 
    abbreviation isEmpty where "isEmpty == map_op_isEmpty ops" 
    abbreviation isSng where "isSng == map_op_isSng ops" 
    abbreviation ball where "ball == map_op_ball ops" 
    abbreviation bex where "bex == map_op_bex ops" 
    abbreviation size where "size == map_op_size ops" 
    abbreviation size_abort where "size_abort == map_op_size_abort ops" 
    abbreviation sel where "sel == map_op_sel ops" 
    abbreviation to_list where "to_list == map_op_to_list ops" 
    abbreviation to_map where "to_map == map_op_to_map ops"
  end

  locale StdMap = StdMapDefs ops +
    map α invar +
    map_empty α invar empty +
    map_lookup α invar lookup  +
    map_update α invar update  +
    map_update_dj α invar update_dj +
    map_delete α invar delete  +
    poly_map_iteratei α invar list_it +
    map_sng α invar sng  +
    map_restrict α invar α invar restrict +
    map_add α invar add  +
    map_add_dj α invar add_dj +
    map_isEmpty α invar isEmpty  +
    map_isSng α invar isSng  +
    map_ball α invar ball  +
    map_bex α invar bex  +
    map_size α invar size +
    map_size_abort α invar size_abort +
    map_sel' α invar sel  +
    map_to_list α invar to_list  +
    list_to_map α invar to_map 
    for ops :: "('k,'v,'s,'more) map_ops_scheme"
  begin
    lemmas correct =
      empty_correct
      sng_correct
      lookup_correct
      update_correct
      update_dj_correct
      delete_correct
      restrict_correct
      add_correct
      add_dj_correct
      isEmpty_correct
      isSng_correct
      ball_correct
      bex_correct
      size_correct
      size_abort_correct
      to_list_correct
      to_map_correct
  end

  lemmas StdMap_intro = StdMap.intro[rem_dup_prems]

  locale StdMap_no_invar = StdMap + map_no_invar α invar

  record ('k,'v,'s) omap_ops = "('k,'v,'s) map_ops" + 
    map_op_ordered_list_it :: "'s  ('k,'v,('k×'v) list) map_iterator"
    map_op_rev_list_it :: "'s  ('k,'v,('k×'v) list) map_iterator"
    map_op_min :: "'s  ('k × 'v  bool)  ('k × 'v) option"
    map_op_max :: "'s  ('k × 'v  bool)  ('k × 'v) option"
    map_op_to_sorted_list :: "'s  ('k × 'v) list"
    map_op_to_rev_list :: "'s  ('k × 'v) list"

  locale StdOMapDefs = StdMapDefs ops
    + poly_map_iterateoi_defs "map_op_ordered_list_it ops"
    + poly_map_rev_iterateoi_defs "map_op_rev_list_it ops"
    for ops :: "('k::linorder,'v,'s,'more) omap_ops_scheme"
  begin
    abbreviation ordered_list_it where "ordered_list_it 
       map_op_ordered_list_it ops"
    abbreviation rev_list_it where "rev_list_it 
       map_op_rev_list_it ops"
    abbreviation min where "min == map_op_min ops"
    abbreviation max where "max == map_op_max ops"
    abbreviation to_sorted_list where 
      "to_sorted_list  map_op_to_sorted_list ops"
    abbreviation to_rev_list where "to_rev_list  map_op_to_rev_list ops"
  end

  locale StdOMap = 
    StdOMapDefs ops +
    StdMap ops +
    poly_map_iterateoi α invar ordered_list_it +
    poly_map_rev_iterateoi α invar rev_list_it +
    map_min α invar min +
    map_max α invar max +
    map_to_sorted_list α invar to_sorted_list +
    map_to_rev_list α invar to_rev_list
    for ops :: "('k::linorder,'v,'s,'more) omap_ops_scheme"
  begin
  end

  lemmas StdOMap_intro = 
    StdOMap.intro[OF StdMap_intro, rem_dup_prems]

end

Theory Robdd

(*  Title:       A simple ROBDD implementation
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section ‹\isaheader{ROBDDs}›
theory Robdd
imports Main "../ICF/spec/MapSpec" "../Iterator/SetIteratorOperations"
        
begin

text ‹Let's first fix some datatypes for BDDs or more specifically
for reduced ordered binary decision diagrams (OBDDs).›

type_synonym node_id = nat
type_synonym var = nat
type_synonym assigment = "var  bool"

datatype robdd = robdd_leaf bool | robdd_var node_id robdd var robdd 
abbreviation "robdd_zero  robdd_leaf False"
abbreviation "robdd_one  robdd_leaf True"

primrec robdd_α where
   "robdd_α (robdd_leaf f) a = f"
 | "robdd_α (robdd_var i l v r) a = (if a v then robdd_α l a else robdd_α r a)"

lemma robdd_α_simps_leafs [simp] : 
  "robdd_α (robdd_leaf f1) = robdd_α (robdd_leaf f2)  (f1 = f2)" 
by (simp add: fun_eq_iff)

primrec robdd_get_id :: "robdd  node_id" where
   "robdd_get_id (robdd_leaf f) = (if f then 1 else 0)"
 | "robdd_get_id (robdd_var i l v r) = i"

primrec robdd_get_var :: "robdd  var" where
   "robdd_get_var (robdd_leaf f) = 0"
 | "robdd_get_var (robdd_var i l v r) = v"

primrec robdd_get_left :: "robdd  robdd" where
   "robdd_get_left (robdd_leaf f) = robdd_leaf f"
 | "robdd_get_left (robdd_var i l v r) = l"

primrec robdd_get_right :: "robdd  robdd" where
   "robdd_get_right (robdd_leaf f) = robdd_leaf f"
 | "robdd_get_right (robdd_var i l v r) = r"

primrec robdd_to_bool :: "robdd  bool option" where
   "robdd_to_bool (robdd_leaf f) = Some f"
 | "robdd_to_bool (robdd_var i l v r) = None"

primrec robdd_is_leaf where
   "robdd_is_leaf (robdd_leaf _) = True"
 | "robdd_is_leaf (robdd_var _ _ _ _) = False"

lemma robdd_is_leaf_alt_def :
  "robdd_is_leaf b  (b = robdd_one  b = robdd_zero)"
by (cases b) auto

text ‹IDs are just used a convinience for performance reasons. Therefore,
        we define two robdds to be equivalent if they are equal up to ids.›
primrec robdd_equiv where
   "robdd_equiv (robdd_leaf f) b = (b = robdd_leaf f)"
 | "robdd_equiv (robdd_var i l v r) b = 
    (i' l' r'. b = robdd_var i' l' v r'  robdd_equiv l l'  robdd_equiv r r')"

lemma robdd_equiv_simps[simp] :
   "robdd_equiv b (robdd_leaf f) = (b = robdd_leaf f)"
   "robdd_equiv b b"
  by (induct b, auto)

subsection ‹subrobdds›

text ‹It is for later definitions important to be able to talk about all the
robdds that form a robdd. This leads to the definition of subrobdds.›

primrec subrobdds :: "robdd  robdd set" where
   "subrobdds (robdd_leaf f) = {robdd_leaf f}"
 | "subrobdds (robdd_var i l v r) = 
    (insert (robdd_var i l v r) (subrobdds l  subrobdds r))"

definition subrobdds_proper :: "robdd  robdd set" where
   "subrobdds_proper b = (subrobdds b) - {b}"

lemma subrobdds_alt_def :
  "subrobdds b = insert b (subrobdds_proper b)"
by (cases b) (simp_all add: subrobdds_proper_def)

lemma subobbds_proper_size: 
  "b1  subrobdds_proper b2  size_robdd b1 < size_robdd b2"
proof (induct b2 arbitrary: b1)
  case (robdd_leaf f) thus ?case by (simp add: subrobdds_proper_def)
next
  case (robdd_var i l v r) 
  note indhyp_l = robdd_var(1)
  note indhyp_r = robdd_var(2)

  from robdd_var(3) have b1_in_cases: "b1  subrobdds l  b1  subrobdds r" by (simp add: subrobdds_proper_def)
  show ?case
  proof (cases "b1  subrobdds l")
    case True with indhyp_l[of b1] show ?thesis
      apply (cases "b1 = l")
      apply (simp_all add: subrobdds_proper_def)
    done
  next
    case False 
    with b1_in_cases have "b1  subrobdds r" by blast
    with indhyp_r[of b1] show ?thesis
      apply (cases "b1 = r")
      apply (simp_all add: subrobdds_proper_def)
    done
  qed
qed

lemma subrobdds_size: 
  "b1  subrobdds b2  size_robdd b1  size_robdd b2"
unfolding subrobdds_alt_def by simp (metis le_eq_less_or_eq subobbds_proper_size)

lemma subrobdds_refl[simp]:  "b  subrobdds b" by (simp add: subrobdds_alt_def)

lemma subrobdds_antisym:  
  "b1  subrobdds b2  b2  subrobdds b1  b1 = b2"
  apply (cases "b1 = b2")
  apply (simp_all add: subrobdds_alt_def)
  apply (metis order_less_asym' subobbds_proper_size)
done

lemma subrobdds_trans :  
  "b1  subrobdds b2  b2  subrobdds b3  b1  subrobdds b3"
  apply (induct b3 arbitrary: b1 b2)
  apply (simp_all)
  apply (elim disjE)
  apply (simp_all)
done

lemma subrobdds_proper_simps [simp] :
   "subrobdds_proper (robdd_leaf f) = {}"
   "subrobdds_proper (robdd_var i l v r) = 
    (insert l (insert r (subrobdds_proper l  subrobdds_proper r)))"
proof -
  show "subrobdds_proper (robdd_leaf f) = {}" 
    by (simp_all add: subrobdds_proper_def)
next
  have "subrobdds_proper (robdd_var i l v r) = subrobdds l  subrobdds r - {robdd_var i l v r}"
    by (simp add: subrobdds_proper_def)
  also have "... = subrobdds l  subrobdds r" 
  proof -
    from subrobdds_size [of "robdd_var i l v r" l] subrobdds_size [of "robdd_var i l v r" r]
    have "robdd_var i l v r  subrobdds l" "robdd_var i l v r  subrobdds r" by auto
    thus ?thesis by auto  
  qed
  also have "... = (insert l (insert r (subrobdds_proper l  subrobdds_proper r)))"
     by (auto simp add: subrobdds_proper_def)
  finally show "subrobdds_proper (robdd_var i l v r) = 
        (insert l (insert r (subrobdds_proper l  subrobdds_proper r)))" .
qed

lemma subrobdds_subset_simp :
  "subrobdds b1  subrobdds b2  b1  subrobdds b2"
by (metis subrobdds_refl subrobdds_trans subset_iff)

definition subrobdds_set where
  "subrobdds_set bs = (subrobdds ` bs)"

lemma subrobdds_set_simps [simp] :
  "subrobdds_set {} = {}"
  "subrobdds_set (insert b bs) = subrobdds b  subrobdds_set bs"
  "subrobdds_set (bs1  bs2) = subrobdds_set bs1  subrobdds_set bs2"
unfolding subrobdds_set_def by simp_all

lemma subrobdds_set_subset_simp :
  "subrobdds b  subrobdds_set bs  b  subrobdds_set bs"
unfolding subrobdds_set_def
by (auto simp add: subset_iff dest: subrobdds_trans)

lemma subrobdds_set_idempot [simp] :
  "subrobdds_set (subrobdds_set bs) = subrobdds_set bs"
unfolding subrobdds_set_def
by (auto dest: subrobdds_trans intro: subrobdds_refl)

lemma subrobdds_set_idempot2 [simp] :
  "subrobdds_set (subrobdds b) = subrobdds b"
using subrobdds_set_idempot[of "{b}"]
by simp

lemma subrobdds_set_mono :
  "bs  subrobdds_set bs"
unfolding subrobdds_set_def by auto

lemma subrobdds_set_mono2 :
  "bs1  bs2  (subrobdds_set bs1  subrobdds_set bs2)"
unfolding subrobdds_set_def by auto

subsection ‹Invariants›

subsubsection ‹IDs›

text ‹Ids are just added for convienience and performance. Two ROBDDs should have
the same id if and only if they have the same semantics. This way, the equivalence check
of ROBDDs can be reduced to an equality check of ids.›

definition robdd_invar_ids where
  "robdd_invar_ids bs =
   (b1 b2. (b1  subrobdds_set bs  b2  subrobdds_set bs) 
              ((robdd_α b1 = robdd_α b2)  robdd_get_id b1 = robdd_get_id b2))" 

text ‹leafs can often be implicitly added›
definition robdd_invar_ids_leafs where
  "robdd_invar_ids_leafs bs =
   (b f. (b  subrobdds_set bs) 
          ((robdd_α b = robdd_α (robdd_leaf f))  robdd_get_id b = robdd_get_id (robdd_leaf f)))" 

definition robdd_invar_ids_full where
  "robdd_invar_ids_full bs 
   robdd_invar_ids bs  robdd_invar_ids_leafs bs"

lemma robdd_invar_ids_full_alt_def :
  "robdd_invar_ids_full bs =
   robdd_invar_ids (insert robdd_zero (insert robdd_one bs))"
unfolding robdd_invar_ids_full_def robdd_invar_ids_def robdd_invar_ids_leafs_def
  apply (simp)
  apply (intro iffI allI impI, elim conjE impE disjE)
  apply (simp_all)
  apply (metis+) [3]
  apply (elim conjE impE disjE)
  apply (simp_all)
  apply (metis+) 
done

text ‹Together with other invariants it can the later be derived that
        two robdds have the same id if and only if they are equal.›
definition robdd_invar_ids_equal where
  "robdd_invar_ids_equal bs =
   (b1 b2. (b1  subrobdds_set bs  b2  subrobdds_set bs) 
              ((robdd_get_id b1 = robdd_get_id b2)  b1 = b2))" 

definition robdd_invar_ids_leafs_equal where
  "robdd_invar_ids_leafs_equal bs =
   (b f. (b  subrobdds_set bs) 
              ((robdd_get_id b = robdd_get_id (robdd_leaf f))  b = (robdd_leaf f)))" 

definition robdd_invar_ids_full_equal where
  "robdd_invar_ids_full_equal bs 
   robdd_invar_ids_equal bs  robdd_invar_ids_leafs_equal bs"

lemma robdd_invar_ids_full_equal_alt_def :
  "robdd_invar_ids_full_equal bs =
   robdd_invar_ids_equal (insert robdd_zero (insert robdd_one bs))"
unfolding robdd_invar_ids_full_equal_def robdd_invar_ids_equal_def robdd_invar_ids_leafs_equal_def
  apply (simp)
  apply (intro iffI allI impI)
  apply (elim conjE impE disjE)
  apply (simp_all)
  apply (metis+) [3]
  apply (metis One_nat_def robdd_get_id.simps(1))
done

lemma robdd_invar_idsI:
assumes "b1 b2. b1  (subrobdds_set bs); b2  (subrobdds_set bs) 
                         (robdd_α b1 = robdd_α b2)  (robdd_get_id b1 = robdd_get_id b2)" 
shows "robdd_invar_ids bs"
using assms unfolding robdd_invar_ids_def by blast

lemma robdd_invar_idsD:
assumes "robdd_invar_ids bs"
assumes "b1  (subrobdds_set bs)"
        "b2  (subrobdds_set bs)"
shows "robdd_α b1 = robdd_α b2  robdd_get_id b1 = robdd_get_id b2"
using assms unfolding robdd_invar_ids_def by blast

lemma robdd_invar_ids_subset_rule :
  "robdd_invar_ids bs1  bs2  bs1  robdd_invar_ids bs2"
by (simp add: robdd_invar_ids_def subset_iff subrobdds_set_def) metis

lemma robdd_invar_ids_expand :
shows "robdd_invar_ids (subrobdds_set bs) = robdd_invar_ids bs"
by (simp add: robdd_invar_ids_def subrobdds_set_idempot)

lemma robdd_invar_ids_subset_subrobdds_rule :
assumes pre: "b2. b2  bs2  b1  bs1. b2  (subrobdds b1)"
    and invar_bs1: "robdd_invar_ids bs1"
shows "robdd_invar_ids bs2"
apply (rule robdd_invar_ids_subset_rule [of "subrobdds_set bs1"])
apply (simp add: robdd_invar_ids_expand invar_bs1)
apply (simp add: subset_iff pre subrobdds_set_def)
done

text ‹If two ROBDDs are equal up to ids and then they are in fact equal.›
lemma robdd_invar_ids_equiv_implies_eq:
assumes "robdd_invar_ids bs"
    and "b1  bs" "b2  bs"
    and "robdd_equiv b1 b2"
  shows "b1 = b2"
using assms
proof (induct b1 arbitrary: b2 bs)
  case (robdd_var i l v r)
  note indhyp_l = robdd_var(1)
  note indhyp_r = robdd_var(2)
  note invar_ids = robdd_var(3)
  note in_bs = robdd_var(4,5)
  note equiv_b2 = robdd_var(6)

  from equiv_b2 obtain i' l' r' where
    b2_eq: "b2 = robdd_var i' l' v r'" and
    equiv_l: "robdd_equiv l l'" and
    equiv_r: "robdd_equiv r r'"
    unfolding robdd_equiv.simps by blast 

  have invar_ids': "robdd_invar_ids {robdd_var i l v r, b2}"
    apply (rule robdd_invar_ids_subset_subrobdds_rule[OF _ invar_ids])
    apply (auto simp add: subrobdds_alt_def in_bs)
  done
  have invar_ids_sub: "robdd_invar_ids {l, r, l', r'}"
    apply (rule robdd_invar_ids_subset_subrobdds_rule[OF _ invar_ids'])
    apply (auto simp add: b2_eq subrobdds_alt_def) 
  done

  from indhyp_l [OF invar_ids_sub _ _ equiv_l] 
       indhyp_r [OF invar_ids_sub _ _ equiv_r] 
  have l'_eq[simp]: "l' = l" and  r'_eq[simp]: "r' = r" by simp_all

  from robdd_invar_idsD[OF invar_ids', of "robdd_var i l v r" b2]
  have i'_eq[simp]: "i' = i" by (simp add: b2_eq robdd_α_def subrobdds_set_def)

  show ?case by (simp add: b2_eq)
qed simp_all


subsubsection ‹Variable order›

text ‹We are formalising reduced \emph{ordered} binary decision diagrams. Therefore, the
variables need to appear in order.›

primrec robdd_invar_vars_greater where
   "robdd_invar_vars_greater n (robdd_leaf f) = True"
 | "robdd_invar_vars_greater n (robdd_var i l v r) = 
    (n  v  (robdd_invar_vars_greater (Suc v) l)  (robdd_invar_vars_greater (Suc v) r))"

definition robdd_invar_vars where
   "robdd_invar_vars b = robdd_invar_vars_greater 0 b"

lemma robdd_invar_vars_greater___weaken :
   "robdd_invar_vars_greater n b  n'  n  robdd_invar_vars_greater n' b"
by (cases b) (simp_all)

lemma robdd_invar_vars_impl: 
  "robdd_invar_vars_greater n robdd   robdd_invar_vars robdd"
unfolding robdd_invar_vars_def
by (rule robdd_invar_vars_greater___weaken[of n]) (simp_all)


subsubsection ‹Reduced›

text ‹We are formalising \emph{reduced} ordered binary decision diagrams. Therefore, it should
be reduced.›

primrec robdd_invar_reduced where
   "robdd_invar_reduced (robdd_leaf f) = True"
 | "robdd_invar_reduced (robdd_var i l v r) =       
     (¬(robdd_equiv l r)  (robdd_invar_reduced l)  (robdd_invar_reduced r))"

lemma robdd_invar_reduced_leaf [simp]: 
   "robdd_invar_reduced (robdd_leaf v) = True"
by (cases v) (simp_all)

lemma subrobdds_leaf_in_reduced: 
"robdd_invar_reduced b  ¬(robdd_is_leaf b)  (robdd_one  subrobdds b  robdd_zero  subrobdds b)"
proof (induct b)
  case (robdd_leaf f)
  thus ?case by simp
next
  case (robdd_var i l v r)
  note reduced_b = robdd_var(3)
  from reduced_b have not_equiv_lr: "¬ robdd_equiv l r" and
    reduced_l: "robdd_invar_reduced l" and reduced_r: "robdd_invar_reduced r"
    by simp_all

  note indhyp_l = robdd_var(1)[OF reduced_l]
  note indhyp_r = robdd_var(2)[OF reduced_r]

  show ?case
  proof (cases "robdd_is_leaf l")
    case False
    with indhyp_l show ?thesis by simp
  next
    case True note l_is_leaf = this

    show ?thesis
    proof (cases "robdd_is_leaf r")
      case False
      with indhyp_r show ?thesis by simp
    next
      case True note r_is_leaf = this

      from l_is_leaf r_is_leaf not_equiv_lr show ?thesis
        unfolding robdd_is_leaf_alt_def by auto
    qed
  qed
qed 

lemma subrobdds_set_leaf_in_reduced: 
assumes bs_OK: "b. b  bs  robdd_invar_reduced b" 
    and bs_neq_leaf_set: "bs  {robdd_one}" "bs  {robdd_zero}" 
    and bs_neq_emp: "bs  {}"
shows "robdd_one  subrobdds_set bs  robdd_zero  subrobdds_set bs"
proof (cases "bbs. ¬(robdd_is_leaf b)")
  case True
  then obtain b where b_in: "b  bs" and not_leaf_b: "¬(robdd_is_leaf b)" by blast

  from bs_OK b_in have invar_reduced: "robdd_invar_reduced b" by simp

  from subrobdds_leaf_in_reduced[OF invar_reduced not_leaf_b]
  have in_b: "robdd_one  subrobdds b  robdd_zero  subrobdds b" .

  from in_b b_in show ?thesis
    unfolding subrobdds_set_def by auto
next
  case False hence only_leafs: "b. b  bs  robdd_is_leaf b" by simp

  from bs_neq_emp obtain b1 where b1_in: "b1  bs" by auto
  with only_leafs have leaf_b1: "robdd_is_leaf b1" by simp

  from leaf_b1 bs_neq_leaf_set have "bs  {b1}"
    by (auto simp add: robdd_is_leaf_alt_def)
  with b1_in obtain b2 where b2_in: "b2  bs" and b2_neq: "b1  b2"
    by auto

  from b2_in only_leafs have leaf_b2: "robdd_is_leaf b2" by simp

  from b1_in b2_in b2_neq leaf_b1 leaf_b2 
  have "robdd_one  bs  robdd_zero  bs" 
    unfolding robdd_is_leaf_alt_def by auto
  thus ?thesis unfolding subrobdds_set_def
    by simp (metis subrobdds_refl)
qed

lemma robdd_invar_ids_leafs_intro :
assumes bs_OK: "b. b  bs  robdd_invar_reduced b"
    and weak_invar: "robdd_invar_ids bs"
shows "robdd_invar_ids_leafs bs"
proof (cases "bs = {}  bs = {robdd_one}  bs = {robdd_zero}")
  case True thus ?thesis
  proof (elim disjE)
    assume "bs = {}" thus "robdd_invar_ids_leafs bs"
      unfolding robdd_invar_ids_leafs_def by simp
  next
    assume "bs = {robdd_one}" thus "robdd_invar_ids_leafs bs"
      unfolding robdd_invar_ids_leafs_def 
      by simp
  next
    assume "bs = {robdd_zero}" thus "robdd_invar_ids_leafs bs"
      unfolding robdd_invar_ids_leafs_def 
      by simp
  qed
next
  case False
  with subrobdds_set_leaf_in_reduced[of bs, OF bs_OK]
  have one_in: "robdd_one  subrobdds_set bs" and
       zero_in: "robdd_zero  subrobdds_set bs" by auto

  with weak_invar show ?thesis
    unfolding robdd_invar_ids_leafs_def robdd_invar_ids_def 
    by auto
qed


subsubsection ‹Overall Invariant›

definition robdd_invar_ext where
  "robdd_invar_ext bs n b = (b  subrobdds_set bs  robdd_invar_ids bs  robdd_invar_vars_greater n b  robdd_invar_reduced b)"

definition robdd_invar where
  "robdd_invar b = robdd_invar_ext {b} 0 b"

lemma robdd_invar_alt_def :
  "robdd_invar b = (robdd_invar_ids {b}  robdd_invar_vars b  robdd_invar_reduced b)"
unfolding robdd_invar_def robdd_invar_ext_def robdd_invar_vars_def subrobdds_set_def
by simp

lemma robdd_invar_simps_leafs [simp]: "robdd_invar (robdd_leaf value)"
  by (simp add: robdd_invar_alt_def robdd_invar_vars_def robdd_invar_ids_def subrobdds_set_def)

lemma robdd_invar_simps_var :
   "robdd_invar (robdd_var i l v r)  (¬(robdd_equiv l r)  robdd_invar l  robdd_invar r)"
  apply (simp add: robdd_invar_alt_def robdd_invar_ids_def robdd_invar_vars_def subrobdds_set_def)
  apply (metis robdd_invar_vars_def robdd_invar_vars_impl)
done

lemma robdd_invar_subrobdds_set :
assumes bs_OK: "b. b  bs  robdd_invar b"
    and b_in: "b  subrobdds_set bs"
  shows "robdd_invar b"
proof -
  from b_in obtain b' where b'_in: "b'  bs" and b_in': "b  subrobdds b'"
    unfolding subrobdds_set_def by auto

  from bs_OK[OF b'_in] have "robdd_invar b'" .
  with b_in' show "robdd_invar b"
    apply (induct b')
    apply simp_all
    apply (metis robdd_invar_simps_var)
  done
qed

lemma robdd_invar_ext_simps [simp] :
   "robdd_invar_ext bs n (robdd_leaf f) = (robdd_invar_ids bs  ((robdd_leaf f)  (subrobdds_set bs)))" (is ?T1)
   "robdd_invar_ext bs n (robdd_var i l v r) =
     ((robdd_var i l v r)  (subrobdds_set bs)  ¬(robdd_equiv l r)  n  v  robdd_invar_ext bs (Suc v) l  robdd_invar_ext bs (Suc v) r)" (is ?T2)
proof -
  show ?T1 by (auto simp add: robdd_invar_ext_def)
next
  show ?T2 (is "?ls = ?rs")
  proof
    assume ?rs thus ?ls by (simp add: robdd_invar_ext_def subrobdds_set_def)
  next
    assume ?ls 
    then obtain b where b_props: "b  bs"  "robdd_var i l v r  subrobdds b" 
      by (auto simp add: robdd_invar_ext_def subrobdds_set_def)

    from subrobdds_trans [of l "robdd_var i l v r" b]
         subrobdds_trans [of r "robdd_var i l v r" b] 
    have "r  subrobdds b" "l  subrobdds b" by (simp_all add: b_props)
    with ?ls b  bs show ?rs by (auto simp add: robdd_invar_ext_def subrobdds_set_def)
  qed
qed

lemma rodd_invar_ext_idempot_subrobdds_set [simp]: 
   "robdd_invar_ext (subrobdds_set bs) n b = robdd_invar_ext bs n b" 
unfolding robdd_invar_ext_def robdd_invar_ids_def
by simp

lemma robdd_invar_ext_weaken :
assumes pre: "robdd_invar_ext bs2 n b"
    and bs2_props: "b2.  b  subrobdds_set bs2  b2  bs1  b1  bs2. b2  (subrobdds b1)"
    and b_in: "b  subrobdds_set bs2  b  subrobdds_set bs1"
    and m_le: "m  n"
shows "robdd_invar_ext bs1 m b"
proof -
  from pre have 
    "b  subrobdds_set bs2"
    "robdd_invar_ids bs2"
    "robdd_invar_vars_greater n b" 
    "robdd_invar_reduced b" 
  unfolding robdd_invar_ext_def by simp_all

  from b  subrobdds_set bs2 b_in
  have b_in: "b  subrobdds_set bs1" by simp

  have invar_ids: "robdd_invar_ids bs1"
    apply (rule robdd_invar_ids_subset_subrobdds_rule [OF bs2_props])
    apply (simp add: b  subrobdds_set bs2)
    apply simp
    apply fact
  done

  have invar_greater: "robdd_invar_vars_greater m b"
    by (rule robdd_invar_vars_greater___weaken[OF ‹robdd_invar_vars_greater n b m_le])

  show ?thesis 
    unfolding robdd_invar_ext_def
    by (simp add: b_in invar_ids ‹robdd_invar_reduced b invar_greater)
qed

lemma robdd_invar_ext_weaken_var :
assumes pre: "robdd_invar_ext bs n b"
    and m_le: "m  n"
shows "robdd_invar_ext bs m b"
  apply (rule robdd_invar_ext_weaken[OF pre _ _ m_le])
  apply (simp_all add: Bex_def)
  apply (metis subrobdds_refl)
done

lemma robdd_invar_impl :
assumes invar_ext: "robdd_invar_ext bs n b"
shows "robdd_invar b"
unfolding robdd_invar_def
apply (rule robdd_invar_ext_weaken[OF invar_ext])
apply (simp_all add: subrobdds_set_def)
done

lemma robdd_α_invar_greater :
assumes invar_vars: "robdd_invar_vars_greater n b"
    and a_equiv: "v. v  n  a1 v = a2 v"
shows  "robdd_α b a1 = robdd_α b a2"
using assms
  apply (induct b) 
  apply (simp_all)
  apply (metis le_Suc_eq robdd_invar_vars_greater___weaken)
done

subsection ‹ROBDDs are unique›

text ‹An important property of ROBDDs is that two ROBDDs have the same semantics if and only
if they are equal (up to ids in our case). Before we can prove this property some 
lemmata are needed.›

lemma robdd_unique_leaf :
assumes invars_b: "robdd_invar_vars b" "robdd_invar_reduced b"
    and sem_eq: "robdd_α b = robdd_α (robdd_leaf value)"
shows "b = (robdd_leaf value)"
using assms
proof (induct b)
  case (robdd_leaf f) thus ?case by (simp add: fun_eq_iff) 
next
  case (robdd_var i l v r)
  note invar_l = robdd_var(1)
  note invar_r = robdd_var(2)
  note invars = robdd_var(3,4)
  note α_eq = robdd_var(5)

  { fix a
    from invars(1) have invars_b11_b12: "robdd_invar_vars_greater (Suc v) l"
                                    "robdd_invar_vars_greater (Suc v) r"
      by (simp_all add: robdd_invar_vars_def)

    let ?a1 = "λv'. if v = v' then True else a v'"
    let ?a2 = "λv'. if v = v' then False else a v'"
    from α_eq have a_neg: "a. (if a v then robdd_α l a else robdd_α r a)  value" 
      by (simp add: fun_eq_iff)

    from robdd_α_invar_greater [OF invars_b11_b12(1), of a ?a1, symmetric]
         robdd_α_invar_greater [OF invars_b11_b12(2), of a ?a2, symmetric]
         a_neg[of ?a1] a_neg[of ?a2]
    have "robdd_α l a = value  robdd_α r a = value" by simp
  } 
  hence α_l: "robdd_α l = robdd_α (robdd_leaf value)" and 
        α_r: "robdd_α r = robdd_α (robdd_leaf value)"
    by (simp_all add: fun_eq_iff)

  from invars have "robdd_invar_vars l" "robdd_invar_vars r"
                   "robdd_invar_reduced l" "robdd_invar_reduced r" 
      apply (simp_all add: robdd_invar_vars_def)
      apply (metis robdd_invar_vars_def robdd_invar_vars_impl)+
    done
  with invar_l[OF _ _ α_l] invar_r[OF _ _ α_r] 
  have "l = r" by simp
  with invars(2) have "False" by simp
  thus ?case by simp
qed

lemma robdd_unique_var :
assumes invars_b1: "robdd_invar_vars (robdd_var i1 l1 v1 r1)" "robdd_invar_reduced (robdd_var i1 l1 v1 r1)"
    and invars_b2: "robdd_invar_vars (robdd_var i2 l2 v2 r2)" "robdd_invar_reduced (robdd_var i2 l2 v2 r2)"
    and sem_neq_b1: "robdd_α l1  robdd_α r1"
    and sem_neq_b2: "robdd_α l2  robdd_α r2"
    and sem_eq: "robdd_α (robdd_var i1 l1 v1 r1) = robdd_α (robdd_var i2 l2 v2 r2)"
shows "v1 = v2  robdd_α l1 = robdd_α l2  robdd_α r1 = robdd_α r2"
proof -
  { fix i1 l1 v1 r1 i2 l2 v2 r2 n1 n2
    assume invars_b1: "robdd_invar_vars_greater n1 (robdd_var i1 l1 v1 r1)" "robdd_invar_reduced (robdd_var i1 l1 v1 r1)"
       and invars_b2: "robdd_invar_vars_greater n2 (robdd_var i2 l2 v2 r2)" "robdd_invar_reduced (robdd_var i2 l2 v2 r2)"
       and sem_neq: "robdd_α l1  robdd_α r1"
       and sem_eq: "robdd_α (robdd_var i1 l1 v1 r1) = robdd_α (robdd_var i2 l2 v2 r2)"
       and ord: "v1  v2"

    from invars_b1(1) have invars_lr1: "robdd_invar_vars_greater (Suc v1) l1"
                                       "robdd_invar_vars_greater (Suc v1) r1" by simp_all

    from invars_b2(1) have invars_lr2: "robdd_invar_vars_greater (Suc v1) l2"
                                       "robdd_invar_vars_greater (Suc v1) r2"
                                       "v1  v2  robdd_invar_vars_greater v1 (robdd_var i1 l1 v1 r1)"
      apply (simp_all add: robdd_invar_ext_def robdd_invar_vars_def)
      apply (metis not_less_eq_eq robdd_invar_vars_greater___weaken ord)
      apply (metis not_less_eq_eq robdd_invar_vars_greater___weaken ord)
      apply (simp add: invars_lr1)
    done

    from sem_eq have sem_eq_a: "a. robdd_α (robdd_var i1 l1 v1 r1) a = robdd_α (robdd_var i2 l2 v2 r2) a" 
      by (simp add: fun_eq_iff)

    define a1 where "a1 a v' = (if v1 = v' then True else a v')" for a v'
    define a2 where "a2 a v' = (if v1 = v' then False else a v')" for a v'

    have a12_eval: "a. a1 a v1" "a. ~(a2 a v1)" "a v. v  v1  a1 a v = a v  a2 a v = a v"
      unfolding a1_def a2_def by simp_all

    { fix a
      from robdd_α_invar_greater [OF invars_lr1(1), of a "a1 a", symmetric]
           robdd_α_invar_greater [OF invars_lr1(2), of a "a2 a", symmetric]
           robdd_α_invar_greater [OF invars_lr2(1), of a "a1 a", symmetric]
           robdd_α_invar_greater [OF invars_lr2(2), of a "a2 a", symmetric]
           robdd_α_invar_greater [OF invars_lr1(1), of a "a2 a", symmetric]
           robdd_α_invar_greater [OF invars_lr1(2), of a "a1 a", symmetric]
           robdd_α_invar_greater [OF invars_lr2(1), of a "a2 a", symmetric]
           robdd_α_invar_greater [OF invars_lr2(2), of a "a1 a", symmetric]
           sem_eq_a[of "a1 a"] sem_eq_a[of "a2 a"]
      have a12_sem : "robdd_α l1 (a1 a) = robdd_α l1 a" "robdd_α l2 (a1 a) = robdd_α l2 a"
                     "robdd_α r1 (a2 a) = robdd_α r1 a" "robdd_α r2 (a2 a) = robdd_α r2 a"
                     "robdd_α l1 (a2 a) = robdd_α l1 a" "robdd_α l2 (a2 a) = robdd_α l2 a"
                     "robdd_α r1 (a1 a) = robdd_α r1 a" "robdd_α r2 (a2 a) = robdd_α r2 a"
                     "v1  v2  robdd_α r1 a = robdd_α (robdd_var i2 l2 v2 r2) a"
                     "v1  v2  robdd_α l1 a = robdd_α (robdd_var i2 l2 v2 r2) a"
        unfolding a1_def a2_def by simp_all
    } note a12_sem = this

    from a12_sem(9,10) have "v1  v2  robdd_α l1 = robdd_α r1"
       by (simp add: fun_eq_iff)
    with sem_neq have v2_eq: "v2 = v1" by metis

    { fix a
      from sem_eq_a[of "a1 a"] sem_eq_a[of "a2 a"] a12_sem[of a]
      have "robdd_α l1 a = robdd_α l2 a  robdd_α r1 a = robdd_α r2 a"
        by (simp add: v2_eq a12_eval)
    }
    hence "v1 = v2  robdd_α l1 = robdd_α l2  robdd_α r1 = robdd_α r2"
      by (simp add: fun_eq_iff v2_eq)
  } note aux = this

  show ?thesis
  proof (cases "v1  v2")
    case True note v1_le = this
    from aux[OF invars_b1[unfolded robdd_invar_vars_def] invars_b2[unfolded robdd_invar_vars_def] sem_neq_b1 sem_eq v1_le]
    show ?thesis by simp
  next
    case False
    hence v2_le: "v2  v1" by simp
    from aux[OF invars_b2[unfolded robdd_invar_vars_def] invars_b1[unfolded robdd_invar_vars_def] sem_neq_b2 sem_eq[symmetric] v2_le]
    show ?thesis by simp
  qed
qed

lemma robdd_equiv_implies_sem_equiv :
  "robdd_equiv b1 b2  robdd_α b1 = robdd_α b2"
proof (induct b1 arbitrary: b2)
  case (robdd_var i l v r)
  note ind_hyp_l = robdd_var(1) 
  note ind_hyp_r = robdd_var(2) 
  note equiv_b2 = robdd_var(3)

  from equiv_b2 obtain i' l' r' where
    b2_eq: "b2 = robdd_var i' l' v r'" and
    equiv_l: "robdd_equiv l l'" and
    equiv_r: "robdd_equiv r r'"
    unfolding robdd_equiv.simps by blast 

  from ind_hyp_l[OF equiv_l] ind_hyp_r[OF equiv_r] b2_eq
  show ?case by simp
qed simp_all

lemma sem_equiv_implies_robdd_equiv :
assumes "robdd_invar_vars b1" "robdd_invar_reduced b1"
    and "robdd_invar_vars b2" "robdd_invar_reduced b2"
    and "robdd_α b1 = robdd_α b2"
shows "robdd_equiv b1 b2"
using assms
proof (induct "(b1, b2)" arbitrary: b1 b2 rule: measure_induct_rule [of "λ(b1,b2). size_robdd b1 + size_robdd b2"])
  case less 
  note ind_hyp = less(1)
  note invars_b1 = less(2,3)
  note invars_b2 = less(4,5)
  note sem_eq = less(6)

  show ?case
  proof (cases b1)
    case (robdd_leaf f) thus ?thesis using robdd_unique_leaf[OF invars_b2] sem_eq by simp
  next
    case (robdd_var i1 l1 v1 r1) note b1_eq = this

    show ?thesis
    proof (cases b2)
      case (robdd_leaf f) thus ?thesis using robdd_unique_leaf[OF invars_b1] sem_eq
        by (simp add: fun_eq_iff)
    next
      case (robdd_var i2 l2 v2 r2) note b2_eq = this

      from invars_b1 invars_b2
      have invars_sub: "robdd_invar_vars l1" "robdd_invar_vars r1" 
                       "robdd_invar_vars l2" "robdd_invar_vars r2" 
                       "robdd_invar_reduced l1" "robdd_invar_reduced r1" 
                       "robdd_invar_reduced l2" "robdd_invar_reduced r2" 
           "¬(robdd_equiv l1 r1)" "¬(robdd_equiv l2 r2)"
        unfolding b1_eq b2_eq by (simp_all add: robdd_invar_vars_def) (metis robdd_invar_vars_def robdd_invar_vars_impl)+

      have aux: "v1 = v2  robdd_α l1 = robdd_α l2  robdd_α r1 = robdd_α r2" 
      proof (rule robdd_unique_var[OF invars_b1[unfolded b1_eq] invars_b2[unfolded b2_eq]])
        show "robdd_α (robdd_var i1 l1 v1 r1) = robdd_α (robdd_var i2 l2 v2 r2)"
           using invars_b1 invars_b2 sem_eq unfolding b1_eq b2_eq by simp_all
      next
        show "robdd_α l1  robdd_α r1"
        proof (rule notI)   
          assume l1_α_eq: "robdd_α l1 = robdd_α r1"
          with ind_hyp [of l1 r1] invars_sub 
          show False by (simp add: b1_eq b2_eq l1_α_eq)
        qed
      next
        show "robdd_α l2  robdd_α r2"
        proof (rule notI)   
          assume l2_α_eq: "robdd_α l2 = robdd_α r2"
          with ind_hyp [of l2 r2] invars_sub 
          show False by (simp add: b1_eq b2_eq l2_α_eq)
        qed
      qed

      with aux ind_hyp [of l1 l2] 
               ind_hyp [of r1 r2] invars_sub
      show ?thesis by (simp_all add: b1_eq b2_eq)
    qed
  qed
qed

lemma robdd_equiv_alt_def_full :
assumes "robdd_invar_vars b1" "robdd_invar_reduced b1"
    and "robdd_invar_vars b2" "robdd_invar_reduced b2"
shows "robdd_equiv b1 b2  robdd_α b1 = robdd_α b2"
by (metis robdd_equiv_implies_sem_equiv sem_equiv_implies_robdd_equiv[OF assms])

lemma robdd_equiv_alt_def :
assumes "robdd_invar b1"
    and "robdd_invar b2"
shows "robdd_equiv b1 b2  robdd_α b1 = robdd_α b2"
using assms
apply (rule_tac robdd_equiv_alt_def_full)
apply (simp_all add: robdd_invar_def robdd_invar_ext_def robdd_invar_vars_def)
done

lemma robdd_unique :
assumes "robdd_invar b1"
    and "robdd_invar b2"
    and "robdd_invar_ids bs"
    and "b1  bs" "b2  bs"
shows "robdd_α b1 = robdd_α b2  b1 = b2"
using robdd_equiv_alt_def [OF assms(1,2)]
      robdd_invar_ids_equiv_implies_eq[of bs, OF assms(3,4,5)]
by blast

lemma robdd_invar_ids_equal_intro :
assumes bs_OK: "b. b  bs  robdd_invar b"
    and weak_invar: "robdd_invar_ids bs"
shows "robdd_invar_ids_equal bs"
proof -  
  { fix b1 b2
    assume b1_in: "b1  subrobdds_set bs" and b2_in: "b2  subrobdds_set bs"
    hence "robdd_invar b1  robdd_invar b2"
      by (metis robdd_invar_subrobdds_set bs_OK)
    with robdd_unique[of b1 b2 "subrobdds_set bs"] b1_in b2_in weak_invar
    have "(robdd_α b1 = robdd_α b2) = (b1 = b2)" by (simp add: robdd_invar_ids_expand)
  }
  with weak_invar show ?thesis
    unfolding robdd_invar_ids_equal_def robdd_invar_ids_def
    by (simp)
qed

lemma robdd_invar_ids_full_equal_intro :
assumes bs_OK: "b. b  bs  robdd_invar b"
    and weak_invar: "robdd_invar_ids_full bs"
shows "robdd_invar_ids_full_equal bs"
unfolding robdd_invar_ids_full_equal_alt_def
apply (rule robdd_invar_ids_equal_intro)
apply (simp, elim disjE)
apply (simp)
apply (simp)
apply (simp add: bs_OK)
apply (simp add: robdd_invar_ids_full_alt_def[symmetric] weak_invar)
done


subsection ‹Variable dependency›

text ‹ROBDDs talk about assignments that consider infinitely many variables. However,
the result depends only on a finite set of variables. Let's have a closer look at these
variables.›

definition robdd_depends_on_var where
  "robdd_depends_on_var v b  (a. robdd_α b (a(v := True))  robdd_α b (a(v := False)))"

lemma robdd_depends_on_varI :
  "robdd_α b (a(v := True))  robdd_α b (a(v := False)) 
   robdd_depends_on_var v b"
unfolding robdd_depends_on_var_def by auto

lemma robbd_depends_on_var_leaf [simp] :
  "¬(robdd_depends_on_var v (robdd_leaf f))"
by (simp_all add: robdd_depends_on_var_def fun_eq_iff)

lemma robdd_depends_on_var_invar_greater:
assumes invar: "robdd_invar_vars_greater n b"
    and m_less: "m < n"
   shows "¬(robdd_depends_on_var m b)"
proof -
  { fix a f

    have "robdd_α b (a(m := f)) = robdd_α b a"
      apply (rule robdd_α_invar_greater[OF invar, of "a(m := f)" a])
      apply (insert m_less)
      apply (simp)
    done
  }
  thus ?thesis by (simp add: robdd_depends_on_var_def)
qed

lemma robbd_depends_on_var_var_impl1 :
assumes depend: "robdd_depends_on_var v (robdd_var i l v' r)"
shows "(v = v')  robdd_depends_on_var v l  robdd_depends_on_var v r"
proof (cases "v = v'")
  case True thus ?thesis by simp
next
  case False note v_neq = this

  from depend obtain a where a_props: 
    "(if a v' then robdd_α l (a(v := True)) else robdd_α r (a(v := True))) 
     (if a v' then robdd_α l (a(v := False)) else robdd_α r (a(v := False)))" 
    unfolding robdd_depends_on_var_def by (auto simp add: v_neq v_neq[symmetric])

  show ?thesis
  proof (cases "a v'")
    case True note a_v'_eq = this

    have "robdd_depends_on_var v l"
      apply (rule robdd_depends_on_varI[of _ a])
      apply (insert a_props a_v'_eq)
      apply (simp)
    done
    thus ?thesis by simp
  next
    case False note a_v'_eq = this

    have "robdd_depends_on_var v r"
      apply (rule robdd_depends_on_varI[of _ a])
      apply (insert a_props a_v'_eq)
      apply (simp)
    done
    thus ?thesis by simp
  qed
qed

lemma robbd_depends_on_var_var :
assumes invar: "robdd_invar (robdd_var i l v' r)"
shows "robdd_depends_on_var v (robdd_var i l v' r) 
       (v = v')  robdd_depends_on_var v l  robdd_depends_on_var v r"
proof (cases "v = v'")
  case True note v_eq = this

  from invar 
      have invar_greater: "robdd_invar_vars_greater (Suc v) l" "robdd_invar_vars_greater (Suc v) r"
     unfolding robdd_invar_def robdd_invar_ext_def v_eq by simp_all

  from invar robdd_equiv_alt_def[of l r]
  have "robdd_α l  robdd_α r" by (metis robdd_invar_simps_var)
  then obtain a where not_equiv: "robdd_α l a  robdd_α r a" by (simp add: fun_eq_iff) metis

  from robdd_α_invar_greater[OF invar_greater(1), of "a (v := True)" a]
  have l_eval: "robdd_α l (a(v := True)) = robdd_α l a" by simp

  from robdd_α_invar_greater[OF invar_greater(2), of "a (v := False)" a]
  have r_eval: "robdd_α r (a(v := False)) = robdd_α r a" by simp

  show ?thesis 
    apply (simp add: v_eq[symmetric] robdd_depends_on_var_def)
    apply (rule exI [where x = a])
    apply (insert not_equiv)
    apply (simp add: r_eval l_eval)
  done
next
  case False note v_neq = this

  from invar have invar_greater: "robdd_invar_vars_greater (Suc v') l" "robdd_invar_vars_greater (Suc v') r"
     unfolding robdd_invar_def robdd_invar_ext_def by simp_all

  { fix a f1 f2

    from robdd_α_invar_greater[OF invar_greater(1), of "a (v' := f1, v := f2)" "a (v := f2)"] 
         robdd_α_invar_greater[OF invar_greater(2), of "a (v' := f1, v := f2)" "a (v := f2)"] 
    have "robdd_α l (a(v' := f1, v := f2)) = robdd_α l (a (v:=f2))" 
         "robdd_α r (a(v' := f1, v := f2)) = robdd_α r (a (v:=f2))" by simp_all
  } note robdd_α_lr_modified = this

  show ?thesis
  proof (cases "robdd_depends_on_var v l")
    case True note depends_on_l = this

    from depends_on_l
    obtain a where not_equiv: "robdd_α l (a(v := True))  robdd_α l (a(v := False))" 
      unfolding robdd_depends_on_var_def by metis

    have "robdd_depends_on_var v (robdd_var i l v' r)"
       unfolding robdd_depends_on_var_def 
       apply (simp add: v_neq[symmetric]) 
       apply (rule exI [where x = "a (v':=True)"])
       apply (insert not_equiv)
       apply (simp add: robdd_α_lr_modified)
    done
    thus ?thesis by (simp add: depends_on_l)
  next
    case False note not_depends_on_l = this
    hence l_simp: "a. robdd_α l (a(v := True)) = robdd_α l (a(v := False))" 
       unfolding robdd_depends_on_var_def by simp

    { fix a 
      assume "robdd_α r (a(v := True))  robdd_α r (a(v := False))"
      hence "robdd_α r (a(v' := False, v := True))  robdd_α r (a(v' := False, v := False))"
       by (simp add: robdd_α_lr_modified)
    }
    thus ?thesis
       unfolding robdd_depends_on_var_def 
       apply (simp add: v_neq[symmetric] v_neq l_simp) 
       by (metis fun_upd_same)
  qed
qed

primrec robdd_used_vars where
   "robdd_used_vars (robdd_leaf f) = {}"
 | "robdd_used_vars (robdd_var i l v r) = robdd_used_vars l  {v}  robdd_used_vars r"

lemma robdd_depends_on_var_eq_used :
  "robdd_invar b 
   robdd_depends_on_var v b  v  robdd_used_vars b"
proof (induct b)
  case (robdd_leaf f)
  thus ?case by (simp add: robdd_depends_on_var_def)
next
  case (robdd_var i l v' r) 
  note indhyp_l = robdd_var(1)
  note indhyp_r = robdd_var(2)

  note invar_b = robdd_var(3)
  from invar_b have invar_l: "robdd_invar l" and invar_r: "robdd_invar r" by (metis robdd_invar_simps_var)+

  from robbd_depends_on_var_var[OF invar_b, of v] indhyp_l[OF invar_l] indhyp_r[OF invar_r]
  show ?case by simp
qed

lemma robdd_depends_on_var_implies_used :
  "robdd_depends_on_var v b  v  robdd_used_vars b"
apply (induct b)
apply (simp_all)
apply (metis robbd_depends_on_var_var_impl1)
done


subsection ‹Inverse Map›

text ‹If the invariant for ids is satisfied, one can find a find a unique mapping between ids
and ROBDDs.›

definition robdd_id_map_OK where
   "robdd_id_map_OK bs m  (b  subrobdds_set bs. m (robdd_get_id b) = Some b)"

lemma robdd_id_map_OK_D :
  "robdd_id_map_OK bs m; b  subrobdds_set bs  m (robdd_get_id b) = Some b"
unfolding robdd_id_map_OK_def by blast

definition robdd_id_map where
  "robdd_id_map bs i = Eps_Opt (λb. b  subrobdds_set bs  robdd_get_id b = i)"

lemma robdd_id_map_properties :
shows "robdd_invar_ids_equal bs  (robdd_id_map_OK bs (robdd_id_map bs))"
proof
  assume ids_strong: "robdd_invar_ids_equal bs"

  { fix b1 b2
    assume "b1  subrobdds_set bs"

    with ids_strong 
    have "b2  subrobdds_set bs  robdd_get_id b2 = robdd_get_id b1  b2 = b1"
      unfolding robdd_invar_ids_equal_def by metis
  }
  thus "robdd_id_map_OK bs (robdd_id_map bs)"
    unfolding robdd_id_map_OK_def robdd_id_map_def
    by simp
next
  assume map_OK: "robdd_id_map_OK bs (robdd_id_map bs)"

  show "robdd_invar_ids_equal bs"
    unfolding robdd_invar_ids_equal_def
  proof (intro allI impI iffI, elim conjE)
    fix b1 b2
    assume b1_in: "b1  subrobdds_set bs"
    assume b2_in: "b2  subrobdds_set bs"
    assume id_eq: "robdd_get_id b1 = robdd_get_id b2"
    
    let ?P = "λb b'. b'  subrobdds_set bs  robdd_get_id b' = robdd_get_id b"

    from map_OK b1_in b2_in have Eps_Opt_Eval: "Eps_Opt (?P b1) = Some b1"  "Eps_Opt (?P b2) = Some b2" 
       unfolding robdd_id_map_OK_def robdd_id_map_def by simp_all

    from id_eq have "?P b1 = ?P b2" by simp
    with Eps_Opt_Eval show "b1 = b2" by (metis option.inject)
  qed simp
qed

lemma robdd_id_map_union :
assumes invar_ids_bs12: "robdd_invar_ids_equal (bs1  bs2)"
shows "robdd_id_map (bs1  bs2) = (robdd_id_map bs1) ++ (robdd_id_map bs2)"
proof 
  fix i
  from invar_ids_bs12 
  have invar_ids_bs1: "robdd_invar_ids_equal bs1" 
   and invar_ids_bs2: "robdd_invar_ids_equal bs2"
     unfolding robdd_invar_ids_equal_def
     by auto
  
  from invar_ids_bs1 invar_ids_bs2 invar_ids_bs12 robdd_id_map_properties
  have map_OK_bs1: "robdd_id_map_OK bs1 (robdd_id_map bs1)"
   and map_OK_bs2: "robdd_id_map_OK bs2 (robdd_id_map bs2)" 
   and map_OK_bs12: "robdd_id_map_OK (bs1  bs2) (robdd_id_map (bs1  bs2))" 
    by simp_all

  show "robdd_id_map (bs1  bs2) i = (robdd_id_map bs1 ++ robdd_id_map bs2) i"
  proof (cases "b. b  subrobdds_set (bs1  bs2)  robdd_get_id b = i")
    case False 
    hence "robdd_id_map (bs1  bs2) i = None" and
          "robdd_id_map bs1 i = None" and
          "robdd_id_map bs2 i = None"
      unfolding robdd_id_map_def Eps_Opt_eq_None by auto
    thus ?thesis by (simp add: map_add_find_left)
  next
    case True then obtain b where 
        b_in: "b  subrobdds_set (bs1  bs2)" 
    and b_id: "robdd_get_id b = i" by auto

    from map_OK_bs12 b_in b_id
    have ls_eq: "robdd_id_map (bs1  bs2) i = Some b"
      unfolding robdd_id_map_OK_def by metis

    have rs_eq: "(robdd_id_map bs1 ++ robdd_id_map bs2) i = Some b"
    proof (cases "b  subrobdds_set bs2")
      case True
      with map_OK_bs2 b_id 
      have rs_eq2: "robdd_id_map bs2 i = Some b"
        unfolding robdd_id_map_OK_def by metis
      from ls_eq rs_eq2 show ?thesis by simp
    next
      case False note b_nin_bs2 = this

      from b_in b_nin_bs2 have "b  subrobdds_set bs1" by simp
      with map_OK_bs1 b_id have rs_eq1: "robdd_id_map bs1 i = Some b"
        unfolding robdd_id_map_OK_def by metis

      from invar_ids_bs12 b_in b_nin_bs2 b_id have "b'. b'  subrobdds_set bs2  robdd_get_id b'  i"
        unfolding robdd_invar_ids_equal_def by simp metis
      hence rs_eq2: "robdd_id_map bs2 i = None"
        unfolding robdd_id_map_def Eps_Opt_eq_None by auto

      from ls_eq rs_eq1 rs_eq2 show ?thesis by (simp add: map_add_find_left)
    qed

    from ls_eq rs_eq show ?thesis by simp
  qed
qed


subsection ‹Extended Boolean Operations›

text ‹For Boolean Operations on ROBDDs it is important to extend boolean operations
to option types. This allows to get the information that the result of the operation does
not depend on the value of some arguments.›

fun bool_op_extend :: "(bool  bool  bool)  
                                (bool option  bool option  bool option)" where
    "bool_op_extend bop None None =
       (if ((bop True False = bop True True)  
            (bop False True = bop True True)  
            (bop False False = bop True True)) then Some (bop True True) else None)" 
  | "bool_op_extend bop None (Some b') = 
       (if (bop True b'  bop False b') then Some (bop False b') else None)"
  | "bool_op_extend bop (Some b) None =
       (if (bop b True  bop b False) then Some (bop b True) else None)"
  | "bool_op_extend bop (Some b) (Some b') = Some (bop b b')"

text ‹Common Operations›

fun bope_neg where
   "bope_neg None = None"
 | "bope_neg (Some True) = Some False"
 | "bope_neg (Some False) = (Some True)"

definition "bope_and = bool_op_extend (λx y. x  y)"
definition "bope_or = bool_op_extend (λx y. x  y)"
definition "bope_nand = bool_op_extend (λx y. ¬(x  y))"
definition "bope_nor = bool_op_extend (λx y. ¬(x  y))"
definition "bope_xor = bool_op_extend (λx y. x  y)"
definition "bope_eq = bool_op_extend (λx y. x = y)"
definition "bope_imp = bool_op_extend (λx y. x  y)"

lemma bool_opt_exhaust:
  "(y = None  P)  (y = Some True  P)  (y = Some False  P)  P"
by auto 
 
lemma bope_and_code [code] :
   "bope_and None None = None"
   "bope_and bo (Some True) = bo"
   "bope_and bo (Some False) = (Some False)"
   "bope_and (Some True) bo = bo"
   "bope_and (Some False) bo = (Some False)"
unfolding bope_and_def
  apply (case_tac [!] bo  rule: bool_opt_exhaust)
  apply (simp_all)
done

lemma bope_or_code [code] :
   "bope_or None None = None"
   "bope_or bo (Some False) = bo"
   "bope_or bo (Some True) = (Some True)"
   "bope_or (Some False) bo = bo"
   "bope_or (Some True) bo = (Some True)"
unfolding bope_or_def
  apply (case_tac [!] bo  rule: bool_opt_exhaust)
  apply (simp_all)
done

lemma bope_nand_code [code] :
   "bope_nand None None = None"
   "bope_nand bo (Some False) = (Some True)"
   "bope_nand (Some False) bo = (Some True)"
   "bope_nand (Some True) (Some True) = (Some False)"
   "bope_nand None (Some True) = None"
   "bope_nand (Some True) None = None"
unfolding bope_nand_def
  apply (case_tac [!] bo  rule: bool_opt_exhaust)
  apply (simp_all)
done

lemma bope_nor_code [code] :
   "bope_nor None None = None"
   "bope_nor bo (Some True) = (Some False)"
   "bope_nor (Some True) bo = (Some False)"
   "bope_nor (Some False) (Some False) = (Some True)"
   "bope_nor None (Some False) = None"
   "bope_nor (Some False) None = None"
unfolding bope_nor_def
  apply (case_tac [!] bo  rule: bool_opt_exhaust)
  apply (simp_all)
done

lemma bope_eq_code [code] :
   "bope_eq None bo = None"
   "bope_eq bo None = None"
   "bope_eq (Some True)  (Some True)  = Some True"
   "bope_eq (Some True)  (Some False) = Some False"
   "bope_eq (Some False) (Some True)  = Some False"
   "bope_eq (Some False) (Some False) = Some True"
unfolding bope_eq_def
  apply (case_tac [!] bo  rule: bool_opt_exhaust)
  apply (simp_all)
done

lemma bope_xor_code [code] :
   "bope_xor None bo = None"
   "bope_xor bo None = None"
   "bope_xor (Some True)  (Some True)  = Some False"
   "bope_xor (Some True)  (Some False) = Some True"
   "bope_xor (Some False) (Some True)  = Some True"
   "bope_xor (Some False) (Some False) = Some False"
unfolding bope_xor_def
  apply (case_tac [!] bo  rule: bool_opt_exhaust)
  apply (simp_all)
done

lemma bope_imp_code [code] :
   "bope_imp None None = None"
   "bope_imp None (Some True) = Some True"
   "bope_imp None (Some False) = None"
   "bope_imp (Some True) bo = bo"
   "bope_imp (Some False) bo = (Some True)"
unfolding bope_imp_def
  apply (case_tac [!] bo  rule: bool_opt_exhaust)
  apply (simp_all)
done


subsection ‹Implementing boolean Combination›

text ‹For building boolean combinations of BDDs it is essential to use
a map storing already used IDs and a cache. 
These datastructures cache can be implemented in different ways. Therefore, here the
needed properties are abstracted by using a locale.›

locale robdd_locale = 
  c: map_empty c_α c_invar c_empty +
  c: map_lookup c_α c_invar c_lookup +
  c: map_update c_α c_invar c_update +
  r: map_empty r_α r_invar r_empty +
  r: map_lookup r_α r_invar r_lookup +
  r: map_update_dj r_α r_invar r_update 
  for c_α :: "'c_map  (nat × nat  robdd option)" and
      c_invar c_empty c_lookup c_update and
      r_α :: "'r_map  (nat × nat × nat  robdd option)" and
      r_invar r_empty r_lookup r_update
  begin

  definition rev_map_invar where
     "rev_map_invar bs rev_map = (r_invar (fst rev_map)  snd rev_map > 1 
        (b  subrobdds_set bs. robdd_invar_ext bs 0 b  robdd_get_id b < (snd rev_map)) 
        (li v ri b. r_α (fst rev_map) (li, v, ri) = Some b  
               (robdd_invar_ext bs v b  b  bs 
                (l r i. b = robdd_var i l v r   
                         robdd_get_id l = li  robdd_get_id r = ri))) 
        (i l r v. robdd_var i l v r  subrobdds_set bs 
                   r_α (fst rev_map) (robdd_get_id l, v, robdd_get_id r) = Some (robdd_var i l v r)))"

  lemma rev_map_invar_empty: 
     "rev_map_invar {} (r_empty(), 2)"
    unfolding rev_map_invar_def by (simp add: r.empty_correct)

  lemma rev_map_invarI[intro!] :
     "r_invar (fst rev_map); snd rev_map > 1;
       b. b  subrobdds_set bs  robdd_invar_ext bs 0 b  robdd_get_id b < (snd rev_map);
       li v ri b. r_α (fst rev_map) (li, v, ri) = Some b  
               (robdd_invar_ext bs v b  b  bs 
                (l r i. b = robdd_var i l v r   
                         robdd_get_id l = li  robdd_get_id r = ri));
       i l r v. robdd_var i l v r  subrobdds_set bs 
                   r_α (fst rev_map) (robdd_get_id l, v, robdd_get_id r) = Some (robdd_var i l v r) 
       rev_map_invar bs rev_map"
    unfolding rev_map_invar_def by blast

  lemma rev_map_invar_D1 :
  assumes "rev_map_invar bs rev_map"
      and "robdd_var i l v r  subrobdds_set bs"
   shows "r_α (fst rev_map) (robdd_get_id l, v, robdd_get_id r) = Some (robdd_var i l v r)"
   using assms unfolding rev_map_invar_def by blast                            

  lemma rev_map_invar_D2 :
  assumes "rev_map_invar bs rev_map"
      and "r_α (fst rev_map) (li, v, ri) = Some b"
   shows "robdd_invar_ext bs v b  b  bs 
          (l r i. b = robdd_var i l v r   
                      robdd_get_id l = li  robdd_get_id r = ri)"
   using assms unfolding rev_map_invar_def by blast                            

  lemma rev_map_invar_D3 :
  assumes "rev_map_invar bs rev_map"
      and "b  subrobdds_set bs"
   shows "robdd_invar_ext bs 0 b" "robdd_get_id b < snd (rev_map)"
   using assms unfolding rev_map_invar_def by blast+                           

  lemma rev_map_invar_implies_invar_ids :
     assumes invar: "rev_map_invar bs rev_map"
       shows "robdd_invar_ids bs"
  proof (cases "bs = {}")
    case True thus ?thesis by (simp add: robdd_invar_ids_def subrobdds_set_def)
  next
    case False 
    then obtain b where "b  bs" by auto
    then have b_in: "b  subrobdds_set bs" 
      unfolding subrobdds_set_def by rule simp
    from rev_map_invar_D3(1)[OF invar b_in]
    show ?thesis by (simp add: robdd_invar_ext_def)
  qed

  lemma rev_map_invar_implies_invar_bs :
     assumes invar: "rev_map_invar bs rev_map"
         and b_in: "b  subrobdds_set bs"
       shows "robdd_invar b"
  using rev_map_invar_D3(1)[OF invar b_in]
  by (rule robdd_invar_impl)

  lemma rev_map_invar_implies_invar_ids_equal :
     assumes invar: "rev_map_invar bs rev_map"
       shows "robdd_invar_ids_equal bs"
  proof -
    note invar_ids = rev_map_invar_implies_invar_ids[OF invar]

    note bs_OK_full = rev_map_invar_implies_invar_bs[OF invar]
    have bs_OK: "b. b  bs  robdd_invar b" 
      by (metis bs_OK_full subrobdds_set_mono subsetD)

    show "robdd_invar_ids_equal bs"
      by (rule robdd_invar_ids_equal_intro [OF bs_OK invar_ids])
  qed

  definition robdd_construct :: "'r_map × node_id  robdd  var  robdd  robdd × ('r_map × node_id)" where
    "robdd_construct rev_map l v r =
     (let l_id = robdd_get_id l in
      let r_id = robdd_get_id r in
      (if l_id = r_id then (l, rev_map) else
       (case r_lookup (l_id, v, r_id) (fst rev_map) of
           Some b  (b, rev_map) 
         | None  (let b = robdd_var (snd rev_map) l v r in
                    (b, (r_update (l_id, v, r_id) b (fst rev_map), Suc (snd rev_map)))))))"

  lemma robdd_construct_correct :
  fixes l v r bs rev_map
  defines "res  robdd_construct rev_map l v r"
  defines "rev_map'  (snd res)"
  defines "b  fst res"
  defines "bs'  insert b bs"
  assumes invar_rev_map: "rev_map_invar bs rev_map"
      and lr_in: "l  bs" "r  bs"
      and invar_lr: "robdd_invar_ext bs (Suc v) l" "robdd_invar_ext bs (Suc v) r"
  shows "robdd_invar_ext bs' v b  rev_map_invar bs' rev_map' 
         robdd_α b = robdd_α (robdd_var 0 l v r)"
  proof -
    define l_id where "l_id = robdd_get_id l"
    define r_id where "r_id = robdd_get_id r"

    note bs_OK = rev_map_invar_implies_invar_bs[OF invar_rev_map] 

    from invar_lr have invar_ids: "robdd_invar_ids bs"
     and lr_in': "l  subrobdds_set bs" "r  subrobdds_set bs"
     unfolding robdd_invar_ext_def by simp_all

    from robdd_invar_ids_equal_intro[of bs, OF bs_OK invar_ids]
         subrobdds_set_mono[of bs]
    have invar_ids_equal: "robdd_invar_ids_equal bs" by (simp add: subset_iff)

    from invar_rev_map have r_invar: "r_invar (fst rev_map)" unfolding rev_map_invar_def by simp

    show ?thesis
    proof (cases "l_id = r_id")
      case True note l_id_eq = this

      from lr_in' invar_ids l_id_eq have l_α: "robdd_α l = robdd_α r"
        unfolding robdd_invar_ids_def l_id_def r_id_def by simp

      from invar_lr(1) have invar_l': "robdd_invar_ext bs v l"
        apply (rule robdd_invar_ext_weaken_var)
        apply (simp)
      done
      from lr_in(1) have bs'_eq: "insert l bs = bs" by auto         
      from res_def l_id_eq show ?thesis
        unfolding robdd_construct_def l_id_def[symmetric] r_id_def[symmetric]
                  b_def bs'_def rev_map'_def
        by (simp add: fun_eq_iff l_α bs'_eq invar_lr(1) invar_rev_map invar_l')
    next
      case False note l_id_neq = this

      show ?thesis
      proof (cases "r_lookup (l_id, v, r_id) (fst rev_map)")
        case (Some b) note map_eq = this

        from r_invar rev_map_invar_D2[OF invar_rev_map, of l_id v r_id b] map_eq 
        obtain l' r' i where
           invar_b: "robdd_invar_ext bs v b" and
           b_in: "b  bs" and
           b_eq: "b = robdd_var i l' v r'" and
           l_id_eq: "robdd_get_id l' = l_id" and 
           r_id_eq: "robdd_get_id r' = r_id"
          unfolding rev_map_invar_def by (auto simp add: r.lookup_correct) 

        from b_in have bs'_eq: "insert b bs = bs" by auto

        have b_α: "robdd_α b = robdd_α (robdd_var 0 l' v r')"
          unfolding b_eq by (simp add: fun_eq_iff) 

        have lr'_eq: "l' = l" "r' = r"
        proof -
          from b_in b_eq have lr'_in': "l'  subrobdds_set bs" "r'  subrobdds_set bs"
            apply (simp_all add: subrobdds_set_def)
            apply (auto intro: bexI [of _ b])
            done

          from invar_ids_equal lr_in' lr'_in' l_id_eq r_id_eq 
          show "l' = l" "r' = r"
             unfolding robdd_invar_ids_equal_def l_id_def r_id_def by auto
        qed
        from res_def l_id_neq show ?thesis
        unfolding robdd_construct_def l_id_def[symmetric] r_id_def[symmetric]
                  bs'_def rev_map'_def b_def
          by (simp add: map_eq bs'_eq invar_b b_α lr'_eq invar_rev_map)
      next
        case None note map_eq = this
        define b' where "b' = robdd_var (snd rev_map) l v r"

        have α_b': "robdd_α b' = robdd_α (robdd_var 0 l v r)"
          unfolding b'_def by (simp add: fun_eq_iff)

        from lr_in' invar_ids l_id_neq have "robdd_α l  robdd_α r"
          unfolding robdd_invar_ids_def l_id_def r_id_def by simp
        with robdd_equiv_implies_sem_equiv[of l r] have l_not_equiv: "~(robdd_equiv l r)" by blast

        from invar_lr
        have b'_invar_vars: "robdd_invar_vars b'" and b'_invar_reduced: "robdd_invar_reduced b'"
          unfolding b'_def robdd_invar_vars_def
          by (simp_all add: robdd_invar_ext_def l_not_equiv)
       
        { fix b2
          assume b2_in: "b2  subrobdds_set bs"

          from rev_map_invar_D3[OF invar_rev_map b2_in]
          have id_neq: "robdd_get_id b2  robdd_get_id b'"
            unfolding b'_def by simp

          have invar_b2: "robdd_invar b2" by (metis b2_in bs_OK)

          have α_b2: "robdd_α b2  robdd_α b'"
          proof (rule notI)
            assume sem_eq: "robdd_α b2 = robdd_α b'"

            with invar_b2 robdd_equiv_alt_def_full[OF b'_invar_vars b'_invar_reduced, of b2]
            have "robdd_equiv b' b2" by (metis robdd_invar_alt_def)
            then obtain i' l' r' where 
               b2_eq: "b2 = robdd_var i' l' v r'" and
               l'_equiv: "robdd_equiv l l'" and
               r'_equiv: "robdd_equiv r r'"
              unfolding b'_def by auto

            have r'_eq[simp]: "r' = r" and l'_eq[simp]: "l' = l"
            proof -        
              have "l'  subrobdds b2" "r'  subrobdds b2"
                unfolding b2_eq by simp_all
              with b2_in have "l'  subrobdds_set bs" "r'  subrobdds_set bs"
                 by (metis subrobdds_set_subset_simp subsetD)+
              with robdd_invar_ids_equiv_implies_eq[of "subrobdds_set bs" l l']
                   robdd_invar_ids_equiv_implies_eq[of "subrobdds_set bs" r r']
              show "r' = r" "l' = l"
                by (simp_all add: l'_equiv r'_equiv robdd_invar_ids_expand invar_ids lr_in')
            qed

            from rev_map_invar_D1[OF invar_rev_map b2_in[unfolded b2_eq]] map_eq
            show "False" by (simp add: l_id_def r_id_def r.lookup_correct r_invar)
          qed
          
          note invar_b2 α_b2 id_neq
        } note in_bs_b'_props = this

        have subrobdds_set_bs_simp: "subrobdds_set (insert b' bs) = insert b' (subrobdds_set bs)"
          unfolding subrobdds_set_def b'_def using lr_in
          by (auto simp add: set_eq_iff Bex_def)

        have invar_ids': "robdd_invar_ids (insert b' bs)" 
        proof (rule robdd_invar_idsI)
          fix b1 b2

          assume b1_in: "b1  subrobdds_set (insert b' bs)" and
                 b2_in: "b2  subrobdds_set (insert b' bs)"

          from b1_in b2_in      
          show "(robdd_α b1 = robdd_α b2) = (robdd_get_id b1 = robdd_get_id b2)"
            unfolding subrobdds_set_bs_simp
            using robdd_invar_idsD[OF invar_ids, of b1 b2] in_bs_b'_props
            by simp metis
        qed

        from invar_ids' b'_invar_reduced b'_invar_vars
        have invar_b': "robdd_invar_ext (insert b' bs) v b'"
          by (simp add: robdd_invar_ext_def robdd_invar_vars_def b'_def)
        
        have invar_rev_map': "rev_map_invar bs' rev_map'"
        proof -          
          let ?rm = "(r_update (l_id, v, r_id) b' (fst rev_map), Suc (snd rev_map))"
          have "rev_map_invar (insert b' bs) ?rm"
          proof 
            from map_eq
            show "r_invar (fst ?rm)" 
              apply (simp)
              apply (rule r.update_dj_correct)
              apply (simp_all add: r_invar r.lookup_correct dom_def)
            done
          next
            from invar_rev_map 
            show "1 < snd ?rm" unfolding rev_map_invar_def by simp
          next
            fix b
            assume b_in: "b  subrobdds_set (insert b' bs)"
            show "robdd_invar_ext (insert b' bs) 0 b  robdd_get_id b < snd ?rm"
            proof (cases "b = b'")
              case True with invar_b' show ?thesis unfolding b'_def by simp
            next
              case False 
              with subrobdds_set_bs_simp b_in 
              have b_in': "b  subrobdds_set bs" by simp
                   
              from rev_map_invar_D3[OF invar_rev_map b_in']
              show ?thesis by (simp add: robdd_invar_ext_def invar_ids')
            qed
          next
            fix i l r v'
            assume b_in: "robdd_var i l v' r  subrobdds_set (insert b' bs)"
            show "r_α (fst ?rm) (robdd_get_id l, v', robdd_get_id r) =
                  Some (robdd_var i l v' r)"
            proof (cases "robdd_var i l v' r = b'")
              case True with map_eq show ?thesis
                by (simp add: b'_def l_id_def[symmetric] r_id_def[symmetric] 
                              r.lookup_correct r_invar dom_def r.update_dj_correct)
            next
              case False
              with subrobdds_set_bs_simp b_in 
              have b_in': "robdd_var i l v' r  subrobdds_set bs" by simp

              from rev_map_invar_D1[OF invar_rev_map b_in'] map_eq
              show ?thesis by (auto simp add: r.lookup_correct r.update_dj_correct dom_def r_invar)
            qed
          next 
            fix li v' ri b
            assume b_intro: "r_α (fst ?rm) (li, v', ri) = Some b"
            show "robdd_invar_ext (insert b' bs) v' b  b  insert b' bs 
                  (l r i. b = robdd_var i l v' r  robdd_get_id l = li  robdd_get_id r = ri)"
            proof (cases "(li, v', ri) = (robdd_get_id l, v, robdd_get_id r)")
              case True note lriv'_eq = this
              with b_intro map_eq have b_eq: "b = b'" 
                by (simp_all add: r.update_dj_correct dom_def r.lookup_correct r_invar l_id_def r_id_def)
              with lriv'_eq show ?thesis 
                apply (simp add: invar_b')
                apply (simp add: b'_def)
              done
            next
              case False
              with b_intro map_eq have b_intro': "r_α (fst rev_map) (li, v', ri) = Some b"
                by (auto simp add: r.lookup_correct r.update_dj_correct dom_def r_invar l_id_def r_id_def)

              from rev_map_invar_D2[OF invar_rev_map b_intro']
              show ?thesis
                apply simp
                apply (simp add: robdd_invar_ext_def invar_ids')
              done
            qed
          qed

          thus ?thesis
          unfolding bs'_def rev_map'_def res_def robdd_construct_def l_id_def[symmetric]
                    r_id_def[symmetric] b_def
            by (simp add: map_eq b'_def[symmetric] α_b' invar_b' l_id_neq)
        qed

        from res_def l_id_neq invar_rev_map'
        show ?thesis
          unfolding robdd_construct_def l_id_def[symmetric] r_id_def[symmetric]
                    bs'_def rev_map'_def b_def
          by (simp add: map_eq b'_def[symmetric] α_b' invar_b' )
      qed
    qed
  qed

  fun (in -) robdd_apply_next where
     "robdd_apply_next (robdd_leaf f) (robdd_leaf f') = 
         (robdd_leaf f, robdd_leaf f, 0, robdd_leaf f', robdd_leaf f')"
   | "robdd_apply_next (robdd_leaf f) (robdd_var i l v r) = (robdd_leaf f, robdd_leaf f, v, l, r)"
   | "robdd_apply_next (robdd_var i l v r) (robdd_leaf f) = (l, r, v, robdd_leaf f, robdd_leaf f)"
   | "robdd_apply_next (robdd_var i l v r) (robdd_var i' l' v' r') = 
     (if v < v' then
       (l, r, v, (robdd_var i' l' v' r'), (robdd_var i' l' v' r'))
     else (if v = v' then
       (l, r, v, l', r')
     else
       ((robdd_var i l v r), (robdd_var i l v r), v', l', r')))"

  definition (in -) robdd_neg_next where
     "robdd_neg_next b = (let (l, r, v, _, _) = robdd_apply_next b robdd_one in (l, r, v))"

  lemma (in -) robdd_neg_simps[code, simp] :
     "robdd_neg_next (robdd_leaf f) = 
         (robdd_leaf f, robdd_leaf f, 0)"
     "robdd_neg_next (robdd_var i l v r) = (l, r, v)"
   unfolding robdd_neg_next_def by simp_all

  fun (in -) robdd_get_min_var where
     "robdd_get_min_var (robdd_leaf _) (robdd_leaf _) = 0"
   | "robdd_get_min_var (robdd_leaf _) (robdd_var _ _ v _) = v"
   | "robdd_get_min_var (robdd_var _ _ v _) (robdd_leaf _) = v"
   | "robdd_get_min_var (robdd_var _ _ v1 _) (robdd_var _ _ v2 _) = (if v1  v2 then v1 else v2)"

  lemma (in -) robdd_apply_next_correct :
    assumes invar_b1: "robdd_invar_ext bs1 n1 b1" 
        and invar_b2: "robdd_invar_ext bs2 n2 b2" 
        and eval: "robdd_apply_next b1 b2 = (b1_l, b1_r, v'', b2_l, b2_r)"
  shows "robdd_α b1_l = (λa. robdd_α b1 (a (v'' := True)))"  (is ?T1)
        "robdd_α b1_r = (λa. robdd_α b1 (a (v'' := False)))"  (is ?T2)
        "robdd_α b2_l = (λa. robdd_α b2 (a (v'' := True)))"  (is ?T3)
        "robdd_α b2_r = (λa. robdd_α b2 (a (v'' := False)))"  (is ?T4)
        "robdd_invar_ext bs1 (Suc v'') b1_l"  (is ?T5)
        "robdd_invar_ext bs1 (Suc v'') b1_r"  (is ?T6)
        "robdd_invar_ext bs2 (Suc v'') b2_l"  (is ?T7)
        "robdd_invar_ext bs2 (Suc v'') b2_r"  (is ?T8)
        "b1_l  subrobdds b1" (is ?T9)
        "b2_l  subrobdds b2" (is ?T10)
        "b1_r  subrobdds b1" (is ?T11)
        "b2_r  subrobdds b2" (is ?T12)
        "robdd_get_min_var b1 b2 = v''" (is ?T13)
        "~(robdd_is_leaf b1  robdd_is_leaf b2) 
         size_robdd b1_l + size_robdd b2_l < size_robdd b1 + size_robdd b2" (is ?T14)
        "~(robdd_is_leaf b1  robdd_is_leaf b2)  
         size_robdd b1_r + size_robdd b2_r < size_robdd b1 + size_robdd b2" (is ?T15)
  proof -
    have "?T1  ?T2  ?T3  ?T4  ?T5  ?T6  ?T7  ?T8  ?T9  ?T10  ?T11  ?T12  ?T13  ?T14  ?T15"
    proof (cases b1)
      case (robdd_leaf f) note b1_eq = this
      show ?thesis
      proof (cases b2)
        case (robdd_leaf f') note b2_eq = this
        with b1_eq eval[symmetric] invar_b1 invar_b2 show ?thesis by (simp add: fun_eq_iff)
      next
        case (robdd_var i' l' v' r') note b2_eq = this
        with b1_eq eval[symmetric] invar_b1 invar_b2 show ?thesis 
          apply (simp add: fun_eq_iff)
          apply (intro allI conjI robdd_α_invar_greater [of "Suc v'"])
          apply (simp_all add: robdd_invar_ext_def)
        done
      qed
    next
      case (robdd_var i l v r) note b1_eq = this
      show ?thesis
      proof (cases b2)
        case (robdd_leaf f') note b2_eq = this
        with b1_eq eval[symmetric] invar_b1 invar_b2 show ?thesis 
          apply (simp add: fun_eq_iff)
          apply (intro allI conjI robdd_α_invar_greater [of "Suc v"])
          apply (simp_all add: robdd_invar_ext_def)
        done
      next
        case (robdd_var i' l' v' r') note b2_eq = this
        show ?thesis
        proof (cases "v < v'")
          case True 
          with robdd_invar_vars_greater___weaken[of "Suc v'" _ "Suc v"] b1_eq b2_eq eval[symmetric] invar_b1 invar_b2 show ?thesis
            apply (simp add: fun_eq_iff)
            apply (intro allI conjI impI robdd_α_invar_greater [of "Suc v''"])
            apply (simp_all add: robdd_invar_ext_def)
          done
        next
          case False hence v'_le: "v'  v" by simp
          show ?thesis
          proof (cases "v = v'")
            case True
            with robdd_invar_vars_greater___weaken[of "Suc v'" _ "Suc v"] b1_eq b2_eq eval[symmetric] invar_b1 invar_b2 show ?thesis
              apply (simp add: fun_eq_iff)
              apply (intro allI conjI impI robdd_α_invar_greater [of "Suc v''"])
              apply (simp_all add: robdd_invar_ext_def)
            done
          next
            case False
            with v'_le have "v' < v" by simp
            with robdd_invar_vars_greater___weaken[of "Suc v" _ "Suc v'"] b1_eq b2_eq eval[symmetric] invar_b1 invar_b2 show ?thesis
              apply (simp add: fun_eq_iff)
              apply (intro allI conjI impI robdd_α_invar_greater [of "Suc v''"])
              apply (simp_all add: robdd_invar_ext_def)
            done
          qed
        qed
      qed
    qed
    thus ?T1 ?T2 ?T3 ?T4 ?T5 ?T6 ?T7 ?T8 ?T9 ?T10 ?T11 ?T12 ?T13 ?T14 ?T15 by auto
  qed

  function robdd_apply where
    "robdd_apply apply_map rev_map bop b1 b2 = 
      (case (bool_op_extend bop (robdd_to_bool b1) (robdd_to_bool b2)) of 
         Some f  (robdd_leaf f, apply_map, rev_map)
       | None  (case c_lookup (robdd_get_id b1, robdd_get_id b2) apply_map of
            Some b3  (b3, apply_map, rev_map)
          | None  (let (l1, r1, var, l2, r2) = robdd_apply_next b1 b2 in 
                     let (l, apply_map, rev_map) = robdd_apply apply_map rev_map bop l1 l2 in
                     let (r, apply_map, rev_map) = robdd_apply apply_map rev_map bop r1 r2 in
                     let (b, rev_map) = robdd_construct rev_map l var r in
                     let apply_map = c_update (robdd_get_id b1, robdd_get_id b2) b apply_map in
                     (b, apply_map, rev_map))))"
   by pat_completeness auto
   termination 
      apply (relation "measure (λ(_, _, _, b1, b2). size_robdd b1 + size_robdd b2)")
      apply simp
      apply (clarify, simp) 
      defer
      apply (clarify, simp) 
   proof -
     fix b1 b2 l1 l2 r1 r2 v bop
     assume bop_eq: "bool_op_extend bop (robdd_to_bool b1) (robdd_to_bool b2) = None"
        and next_eq: "(l1, r1, v, l2, r2) = robdd_apply_next b1 b2"

     hence "size_robdd l1 + size_robdd l2 < size_robdd b1 + size_robdd b2  
           size_robdd r1 + size_robdd r2 < size_robdd b1 + size_robdd b2" 
       apply (case_tac [!] b1)
       apply (case_tac [!] b2)
       apply (simp_all split: if_splits)
     done
     thus "size_robdd l1 + size_robdd l2 < size_robdd b1 + size_robdd b2" 
          "size_robdd r1 + size_robdd r2 < size_robdd b1 + size_robdd b2" by simp_all
  qed
  declare robdd_apply.simps[simp del]

  definition apply_map_invar where
     "apply_map_invar bop bs bs1 bs2 apply_map 
       c_invar apply_map 
       (i1 i2 b. c_lookup (i1, i2) apply_map = Some b 
          (b1 b2. robdd_id_map bs1 i1 = Some b1  robdd_id_map bs2 i2 = Some b2             
                  robdd_invar_ext bs (robdd_get_min_var b1 b2) b  (a. robdd_α b a  bop (robdd_α b1 a) (robdd_α b2 a))))"

  lemma apply_map_invar_empty : 
    "apply_map_invar bop bs bs1 bs2 (c_empty ())"
    unfolding apply_map_invar_def by (simp add: c.empty_correct c.lookup_correct)

  lemma apply_map_invar_I :
    "c_invar apply_map;
      i1 i2 b. c_lookup (i1, i2) apply_map = Some b 
      b1 b2. robdd_id_map bs1 i1 = Some b1  robdd_id_map bs2 i2 = Some b2             
                  robdd_invar_ext bs (robdd_get_min_var b1 b2) b  (a. robdd_α b a  bop (robdd_α b1 a) (robdd_α b2 a)) 
      apply_map_invar bop bs bs1 bs2 apply_map"
   unfolding apply_map_invar_def by blast

  lemma apply_map_invar_D1 :
    "apply_map_invar bop bs bs1 bs2 apply_map  c_invar apply_map"
   unfolding apply_map_invar_def by blast

  lemma apply_map_invar_D2 :
    "apply_map_invar bop bs bs1 bs2 apply_map;
      c_lookup (i1, i2) apply_map = Some b 
      b1 b2. robdd_id_map bs1 i1 = Some b1  robdd_id_map bs2 i2 = Some b2             
                  robdd_invar_ext bs (robdd_get_min_var b1 b2) b  (a. robdd_α b a  bop (robdd_α b1 a) (robdd_α b2 a))"
   unfolding apply_map_invar_def by blast

  lemma apply_map_invar_extend :
    assumes invar: "apply_map_invar bop bs bs1 bs2 apply_map"
        and bs1'_OK: "bs1  bs1'" "robdd_invar_ids bs1'" "b. b  bs1'  robdd_invar b"
        and bs2'_OK: "bs2  bs2'" "robdd_invar_ids bs2'" "b. b  bs2'  robdd_invar b"
    shows "apply_map_invar bop bs bs1' bs2' apply_map"
  proof (rule apply_map_invar_I, goal_cases)
    case 1
    thus ?case using apply_map_invar_D1[OF invar] .
  next
    case lookup_eq: (2 i1 i2 b)
  
    from apply_map_invar_D2[OF invar lookup_eq]
    obtain b1 b2 where
       id_map_bs1: "robdd_id_map bs1 i1 = Some b1" and
       id_map_bs2: "robdd_id_map bs2 i2 = Some b2" and
       invar_b:    "robdd_invar_ext bs (robdd_get_min_var b1 b2) b" and
       sem_b:      "a. robdd_α b a = bop (robdd_α b1 a) (robdd_α b2 a)"
      by blast

    from bs1'_OK(1) obtain bs1'' where bs1'_eq: "bs1' = bs1''  bs1" by auto
    from bs2'_OK(1) obtain bs2'' where bs2'_eq: "bs2' = bs2''  bs2" by auto
  
    from robdd_invar_ids_equal_intro  [OF bs1'_OK(3) bs1'_OK(2)] bs1'_eq
    have ids_equal_bs1': "robdd_invar_ids_equal (bs1''  bs1)" by simp

    from robdd_invar_ids_equal_intro  [OF bs2'_OK(3) bs2'_OK(2)] bs2'_eq
    have ids_equal_bs2': "robdd_invar_ids_equal (bs2''  bs2)" by simp

    show ?case
      apply (rule_tac exI[where x = b1])
      apply (rule_tac exI[where x = b2])
      apply (simp add: invar_b sem_b bs1'_eq bs2'_eq
                       robdd_id_map_union [OF ids_equal_bs1']
                       robdd_id_map_union [OF ids_equal_bs2']
                       map_add_Some_iff id_map_bs1 id_map_bs2)
    done
  qed

  lemma robdd_apply_correct_full :
  fixes b1 b2 bop rev_map apply_map bs
  defines "res  robdd_apply apply_map rev_map bop b1 b2"
  defines "b  fst res"
  defines "apply_map'  fst (snd res)"
  defines "rev_map'  snd (snd res)"
  assumes invar_rev_map: "rev_map_invar bs rev_map"
      and invar_apply_map: "apply_map_invar bop bs bs1 bs2 apply_map"
      and b1_invar: "robdd_invar_ext bs1 n b1"      
      and b2_invar: "robdd_invar_ext bs2 n b2"      
      and bs1_OK: "b. b  bs1  robdd_invar b"
      and bs2_OK: "b. b  bs2  robdd_invar b"
  shows "bs'. 
         subrobdds b  bs  bs'  
         robdd_invar_ext bs' n b 
         apply_map_invar bop bs' bs1 bs2 apply_map' 
         rev_map_invar bs' rev_map' 
         (a. robdd_α b a  bop (robdd_α b1 a) (robdd_α b2 a))"         
  using invar_rev_map invar_apply_map b1_invar b2_invar 
  unfolding b_def apply_map'_def rev_map'_def res_def
  proof (induct "(b1, b2)" arbitrary: b1 b2 bs n apply_map rev_map  rule: measure_induct_rule [of "λ(b1, b2). size_robdd b1 + size_robdd b2"])
    case less
    note indhyp = less(1)
    note invar_rev_map = less(2)
    note invar_apply_map = less(3)
    note b1_invar = less(4)
    note b2_invar = less(5)
    let ?res = "robdd_apply apply_map rev_map bop b1 b2"
    note res_def = robdd_apply.simps [of apply_map rev_map bop b1 b2]

    from rev_map_invar_implies_invar_ids[OF invar_rev_map] 
    have invar_ids_bs: "robdd_invar_ids bs" by simp
    note bs_OK_full = rev_map_invar_implies_invar_bs[OF invar_rev_map]
    have bs_OK: "b. b  bs  robdd_invar b" by (metis bs_OK_full subrobdds_set_mono subsetD)

    from b1_invar have b1_in: "b1  subrobdds_set bs1" unfolding robdd_invar_ext_def by simp
    from b2_invar have b2_in: "b2  subrobdds_set bs2" unfolding robdd_invar_ext_def by simp
    from b1_invar have invar_ids_bs1: "robdd_invar_ids bs1" unfolding robdd_invar_ext_def by simp
    from b2_invar have invar_ids_bs2: "robdd_invar_ids bs2" unfolding robdd_invar_ext_def by simp
    have invar_ids_equal_bs1: "robdd_invar_ids_equal bs1"
      by (rule robdd_invar_ids_equal_intro [OF bs1_OK invar_ids_bs1])
    have invar_ids_equal_bs2: "robdd_invar_ids_equal bs2"
      by (rule robdd_invar_ids_equal_intro [OF bs2_OK invar_ids_bs2])

    have invar_ids_leafs_bs : "robdd_invar_ids_leafs bs"
    proof (rule robdd_invar_ids_leafs_intro[of bs, OF _ invar_ids_bs])
      fix b
      assume "b  bs"
      with bs_OK[of b] have "robdd_invar b" by simp
      thus "robdd_invar_reduced b" unfolding robdd_invar_def robdd_invar_ext_def by simp
    qed 

    show "bs'. subrobdds (fst ?res)  bs  bs'  
          robdd_invar_ext bs' n (fst ?res) 
          apply_map_invar bop bs' bs1 bs2 (fst (snd ?res)) 
          rev_map_invar bs' (snd (snd ?res)) 
          (a. robdd_α (fst ?res) a = bop (robdd_α b1 a) (robdd_α b2 a))" 
          (is "bs'. ?P bs'")
    proof (cases "bool_op_extend bop (robdd_to_bool b1) (robdd_to_bool b2)")
      case (Some f) note extend_eq_Some = this
  
      have res_eq[simp]: "?res = (robdd_leaf f, apply_map, rev_map)" 
        using res_def
        by (simp add: extend_eq_Some)

      from extend_eq_Some have f_eq: "a. f = bop (robdd_α b1 a) (robdd_α b2 a)"
        apply (case_tac b1, case_tac [!] b2)
        apply (simp_all split: if_splits)
        apply (auto, (metis(full_types))+)
      done

      from invar_ids_leafs_bs invar_ids_bs 
      have invar_ids_bs': "robdd_invar_ids (insert (robdd_leaf f) bs)"
        apply (simp add: robdd_invar_ids_leafs_def robdd_invar_ids_def) 
        apply (intro allI impI)
        apply (elim conjE disjE)
        apply (simp_all)
        apply (metis One_nat_def)
      done

      have invar_ids_equal_bs': "robdd_invar_ids_equal (insert (robdd_leaf f) bs)"
        apply (rule robdd_invar_ids_equal_intro [OF _ invar_ids_bs'])
        apply (auto simp add: bs_OK)
      done

      from invar_rev_map invar_ids_bs'
      have invar_rev_map': "rev_map_invar (insert (robdd_leaf f) bs) rev_map"
        unfolding rev_map_invar_def by (simp add: robdd_invar_ext_def)
 
      from robdd_id_map_union [of "{robdd_leaf f}" bs] invar_ids_equal_bs'
      have id_map'_eq: "robdd_id_map (insert (robdd_leaf f) bs) = robdd_id_map {robdd_leaf f} ++ robdd_id_map bs" 
        by simp

      from invar_apply_map 
      have invar_apply_map': "apply_map_invar bop (insert (robdd_leaf f) bs) bs1 bs2 apply_map"
        unfolding apply_map_invar_def robdd_invar_ext_def invar_ids_equal_bs'
        by (simp add: invar_ids_bs') metis

      have "?P (insert (robdd_leaf f) bs)" by (simp add: invar_ids_bs' f_eq invar_rev_map' invar_apply_map')
      thus ?thesis by blast
    next
      case None note extend_eq_None = this

      have min_var_b12_ge_n: "(robdd_get_min_var b1 b2)  n"
      proof - 
        from b1_invar b2_invar have "robdd_invar_vars_greater n b1  robdd_invar_vars_greater n b2"
          unfolding robdd_invar_ext_def by simp_all
        with extend_eq_None show "(robdd_get_min_var b1 b2)  n"
          by (cases b1, case_tac [!] b2, simp_all)
      qed

      show ?thesis
      proof (cases "c_lookup (robdd_get_id b1, robdd_get_id b2) apply_map")
        case (Some b3) note lookup_eq_Some = this

        from extend_eq_None lookup_eq_Some res_def 
        have res_eq[simp]: "?res = (b3, apply_map, rev_map)" 
          by simp

        from apply_map_invar_D2[OF invar_apply_map, OF lookup_eq_Some]
             robdd_id_map_properties[of bs1] invar_ids_equal_bs1
             robdd_id_map_properties[of bs2] invar_ids_equal_bs2 
             b1_in b2_in
        have invar_b3: "robdd_invar_ext bs (robdd_get_min_var b1 b2) b3" and
             sem_b3: "a. robdd_α b3 a = bop (robdd_α b1 a) (robdd_α b2 a)" 
          by (simp_all add: robdd_id_map_OK_def)

        from invar_b3 have b3_in: "b3  subrobdds_set bs" unfolding robdd_invar_ext_def by simp
        hence subrobdds_b3_bs_eq: "subrobdds_set (subrobdds b3  bs) = subrobdds_set bs"
          using subrobdds_set_subset_simp[of b3 bs] by auto

        from subrobdds_b3_bs_eq invar_b3 
        have invar_b3': "robdd_invar_ext (subrobdds b3  bs) n b3"           
           unfolding robdd_invar_ext_def
           using robdd_invar_ids_expand[of "subrobdds b3  bs", symmetric]
                 robdd_invar_ids_expand[of bs]
                 robdd_invar_vars_greater___weaken[OF _ min_var_b12_ge_n, of b3] by simp 
        from invar_b3' have invar_ids': "robdd_invar_ids (subrobdds b3  bs)" 
          unfolding robdd_invar_ext_def by simp

        from invar_rev_map invar_ids'
        have invar_rev_map': "rev_map_invar (subrobdds b3  bs) rev_map"
          unfolding rev_map_invar_def subrobdds_b3_bs_eq robdd_invar_ext_def
          by simp
 
        from invar_apply_map invar_ids'
        have invar_apply_map': "apply_map_invar bop (subrobdds b3  bs) bs1 bs2 apply_map" 
           unfolding apply_map_invar_def robdd_invar_ext_def by simp blast

        have "?P (subrobdds b3  bs)" by (simp add: invar_b3' sem_b3 invar_rev_map' invar_apply_map')
        thus ?thesis by blast
      next
        case None note lookup_eq_None = this

        from extend_eq_None have not_leaf_b12: "~(robdd_is_leaf b1  robdd_is_leaf b2)"
          by (cases b1, case_tac [!] b2) simp_all

        obtain b1_l b1_r v'' b2_l b2_r where 
          next_eq: "robdd_apply_next b1 b2 = (b1_l, b1_r, v'', b2_l, b2_r)" by (metis prod.exhaust)
        obtain l apply_map' rev_map' where 
          apply_l_eq: "robdd_apply apply_map rev_map bop b1_l b2_l = (l, apply_map', rev_map')"
          by (metis prod.exhaust)
        obtain r apply_map'' rev_map'' where 
          apply_r_eq: "robdd_apply apply_map' rev_map' bop b1_r b2_r = (r, apply_map'', rev_map'')"
          by (metis prod.exhaust)
        obtain b' rev_map''' where const_eq: "robdd_construct rev_map'' l v'' r = (b', rev_map''')"
          by (metis prod.exhaust)
        define apply_map'''
          where "apply_map''' = c_update (robdd_get_id b1, robdd_get_id b2) b' apply_map''"
        note next_props = robdd_apply_next_correct [OF b1_invar b2_invar next_eq] not_leaf_b12
        note v''_eq = next_props(13)

        have res_eq[simp]: "?res =(b', apply_map''', rev_map''')"
          by (simp_all add: b_def next_eq res_def extend_eq_None lookup_eq_None apply_r_eq apply_l_eq
                               const_eq apply_map'_def apply_map'''_def rev_map'_def)      

        from indhyp [of b1_l b2_l bs rev_map apply_map "Suc v''"]
        obtain bs' where
             subset_bs': "subrobdds l  bs  bs'" and
             l_invar0: "robdd_invar_ext bs' (Suc v'') l" and
             invar_apply_map': "apply_map_invar bop bs' bs1 bs2 apply_map'" and
             invar_rev_map': "rev_map_invar bs' rev_map'" and
             sem_l: "a. robdd_α l a = bop (robdd_α b1 (a(v'' := True))) 
                                           (robdd_α b2 (a(v'' := True)))"
          by (simp add: apply_l_eq next_props  invar_rev_map invar_apply_map) metis

        from indhyp [of b1_r b2_r bs' rev_map' apply_map' "Suc v''"]
        obtain bs'' where
             subset_bs'': "subrobdds r  bs'  bs''" and
             r_invar1: "robdd_invar_ext bs'' (Suc v'') r" and
             invar_apply_map'': "apply_map_invar bop bs'' bs1 bs2 apply_map''" and
             invar_rev_map'': "rev_map_invar bs'' rev_map''" and
             sem_r: "a. robdd_α r a = bop (robdd_α b1 (a(v'' := False))) 
                                           (robdd_α b2 (a(v'' := False)))"
          by (simp add: apply_r_eq next_props invar_rev_map' invar_apply_map') metis

        from subset_bs' have "l  bs'" by auto
        with subset_bs'' have l_in_bs'': "l  bs''" by auto
        from subset_bs'' have r_in_bs'': "r  bs''" by auto

        from l_invar0 r_invar1 l_in_bs''
        have l_invar1: "robdd_invar_ext bs'' (Suc v'') l"
          unfolding robdd_invar_ext_def by simp (metis subrobdds_set_mono subsetD)

        define bs''' where "bs''' = insert b' bs''"
        from robdd_construct_correct[OF invar_rev_map'' _ _ l_invar1 r_invar1]
        have b'_invar: "robdd_invar_ext bs''' v'' b'"
         and invar_rev_map''': "rev_map_invar bs''' rev_map'''"
         and sem_b': "robdd_α b' = robdd_α (robdd_var 0 l v'' r)" 
          by (simp_all add: const_eq bs'''_def l_in_bs'' r_in_bs'')

        have sem_OK: "a. robdd_α b' a = bop (robdd_α b1 a) (robdd_α b2 a)"
          by (simp add: sem_b' sem_l sem_r fun_upd_idem)

        have "?P (subrobdds_set bs''')"
          unfolding res_eq fst_conv snd_conv
        proof (intro conjI)
          from subset_bs'' subset_bs' have "bs  bs''" by auto
          with subrobdds_set_mono2 [of bs bs''] 
          have "subrobdds_set bs  subrobdds_set bs''" by simp
          with subrobdds_set_mono[of bs]
          have "bs  subrobdds_set bs''" by simp
          thus "subrobdds b'  bs  subrobdds_set bs'''"
            unfolding bs'''_def            
            by (simp add: subset_iff)
        next
          from b'_invar
          show "robdd_invar_ext (subrobdds_set bs''') n b'"
            unfolding robdd_invar_ext_def robdd_invar_ids_def
            using robdd_invar_vars_greater___weaken[of v'' b' n]
                  v''_eq min_var_b12_ge_n by simp
        next
          show "a. robdd_α b' a = bop (robdd_α b1 a) (robdd_α b2 a)" by fact
        next
          from invar_rev_map''' subrobdds_set_mono[of bs''']
          show "rev_map_invar (subrobdds_set bs''') rev_map'''"
            unfolding rev_map_invar_def by (simp add: subset_iff)
        next          
          from robdd_id_map_properties[of bs1] invar_ids_equal_bs1 b1_in
          have id_map_b1: "robdd_id_map bs1 (robdd_get_id b1) = Some b1"
            by (simp add: robdd_id_map_OK_def)

          from robdd_id_map_properties[of bs2] invar_ids_equal_bs2 b2_in
          have id_map_b2: "robdd_id_map bs2 (robdd_get_id b2) = Some b2"
            by (simp add: robdd_id_map_OK_def)

          { fix n b
            assume b_invar: "robdd_invar_ext bs'' n b"

            from b'_invar have ids_bs''': "robdd_invar_ids bs'''" unfolding robdd_invar_ext_def by simp
 
            from b_invar subrobdds_set_mono2 [of bs'' bs'''] ids_bs'''
            have "robdd_invar_ext bs''' n b"
              unfolding robdd_invar_ext_def bs'''_def by simp
          } note invar_bs'''_ext = this

          from invar_apply_map'' b'_invar
          show "apply_map_invar bop (subrobdds_set bs''') bs1 bs2 apply_map'''"
            unfolding apply_map'''_def apply_map_invar_def
            apply (elim conjE)
            apply (simp add: c.lookup_correct c.update_correct id_map_b1 id_map_b2 v''_eq sem_OK)
            apply (metis invar_bs'''_ext)
          done
        qed
        thus ?thesis by blast
      qed 
    qed
  qed
  
  lemma robdd_apply_correct :
  fixes b1 b2 bop rev_map apply_map 
  defines "res  robdd_apply (c_empty ()) (r_empty (), 2) bop b1 b2"
  defines "b  fst res"
  assumes b1_invar: "robdd_invar b1"      
      and b2_invar: "robdd_invar b2"      
  shows "robdd_invar b  (a. robdd_α b a  bop (robdd_α b1 a) (robdd_α b2 a))"         
  proof -
    from robdd_apply_correct_full [OF rev_map_invar_empty apply_map_invar_empty
          b1_invar[unfolded robdd_invar_def] b2_invar[unfolded robdd_invar_def], of bop,
          folded res_def b_def] b1_invar b2_invar
    obtain bs where invar_ext: "robdd_invar_ext bs 0 b"
                and sem_OK: "a. robdd_α b a = bop (robdd_α b1 a) (robdd_α b2 a)" by auto

    from invar_ext have invar: "robdd_invar b"
      by (rule robdd_invar_impl)
    
    from invar sem_OK show ?thesis by simp
  qed

  definition robdd_neg where
    "robdd_neg apply_map rev_map b = robdd_apply apply_map rev_map (λb1 b2. ¬(b1  b2)) b robdd_one"

  lemma robdd_neg_correct_full :
  fixes b rev_map apply_map bs
  defines "res  robdd_neg apply_map rev_map b"
  defines "b'  fst res"
  defines "apply_map'  fst (snd res)"
  defines "rev_map'  snd (snd res)"
  assumes invar_rev_map: "rev_map_invar bs rev_map"
      and invar_apply_map: "apply_map_invar (λb1 b2. ¬(b1  b2)) bs bs1 bs2 apply_map"
      and b_invar: "robdd_invar_ext bs1 n b"      
      and bs1_OK: "b. b  bs1  robdd_invar b"
      and bs2_OK: "b. b  bs2  robdd_invar b" "robdd_invar_ids bs2"
  shows "bs'. 
         subrobdds b'  bs  bs'  
         robdd_invar_ext bs' n b' 
         apply_map_invar (λb1 b2. ¬(b1  b2)) bs' bs1 
              (insert robdd_zero (insert robdd_one bs2)) apply_map' 
         rev_map_invar bs' rev_map' 
         (a. robdd_α b' a  ¬ (robdd_α b a))"
  proof -

    from bs2_OK have "robdd_invar_ids_leafs bs2"
      apply (rule_tac robdd_invar_ids_leafs_intro)
      apply (simp_all add: robdd_invar_def robdd_invar_ext_def)
    done
    with bs2_OK(2) have "robdd_invar_ids_full bs2" by (simp add: robdd_invar_ids_full_def)
    hence bs2'_invar: "robdd_invar_ids (insert robdd_zero (insert robdd_one bs2))"
      unfolding robdd_invar_ids_full_alt_def by simp 

    from b_invar
    have bs1_invar: "robdd_invar_ids bs1"
      unfolding robdd_invar_ext_def by simp 
   
    from invar_apply_map have
      invar_apply_map': "apply_map_invar (λb1 b2. ¬(b1  b2)) bs bs1 
           (insert robdd_zero (insert robdd_one bs2)) apply_map"
      apply (rule apply_map_invar_extend)
      apply (auto simp add: subset_iff bs1_OK bs2_OK bs2'_invar bs1_invar)
    done

    from robdd_apply_correct_full[OF invar_rev_map invar_apply_map' b_invar _ bs1_OK, of robdd_one]
         res_def[symmetric]
    show ?thesis apply (simp add: robdd_neg_def b'_def[symmetric] apply_map'_def[symmetric]
       rev_map'_def[symmetric])
       by (metis bs2_OK(1) bs2'_invar robdd_invar_simps_leafs)
  qed

  lemma robdd_neg_correct :
  fixes b rev_map apply_map bs
  defines "res  robdd_neg (c_empty ()) (r_empty (), 2) b"
  defines "bn  fst res"
  assumes b_invar: "robdd_invar b"      
  shows "robdd_invar bn  (a. robdd_α bn a  ¬(robdd_α b a))"         
    unfolding res_def bn_def robdd_neg_def
    using robdd_apply_correct [OF b_invar, of robdd_one "(λb1 b2. ¬(b1  b2))"]
    by simp

  lemma robdd_neg_alt_def :
    "robdd_neg apply_map rev_map b = 
      (case (bope_neg (robdd_to_bool b)) of 
         Some f  (robdd_leaf f, apply_map, rev_map)
       | None  (case c_lookup (robdd_get_id b, 1) apply_map of
            Some b3  (b3, apply_map, rev_map)
          | None  (let (l1, r1, var) = robdd_neg_next b in 
                     let (l, apply_map, rev_map) = robdd_neg apply_map rev_map l1 in
                     let (r, apply_map, rev_map) = robdd_neg apply_map rev_map r1 in
                     let (b3, rev_map) = robdd_construct rev_map l var r in
                     let apply_map = c_update (robdd_get_id b, 1) b3 apply_map in
                     (b3, apply_map, rev_map))))"
   proof -
     have bope_neg_intro: 
        "(bool_op_extend (λb1 b2. b1  ¬ b2) (robdd_to_bool b) (Some True)) =
         (bope_neg (robdd_to_bool b))" 
        apply (cases "robdd_to_bool b" rule: bool_opt_exhaust)
        apply (simp_all)
     done

     obtain b1_l b1_r v'' b2_l b2_r where 
       next_eq: "robdd_apply_next b robdd_one = (b1_l, b1_r, v'', b2_l, b2_r)" by (metis prod.exhaust)

     from next_eq have b2_eq[simp]: "b2_l = robdd_one" "b2_r = robdd_one"
       by (case_tac[!] b) auto

     show ?thesis
       unfolding robdd_neg_def robdd_apply.simps[of _ _ _ b]
       by (simp split: option.splits add: bope_neg_intro next_eq split_def robdd_neg_next_def)
   qed

  text ‹An auxiliary construct to get the ids of a ROBDD consistent with some cache or
          other ROBDDs.›
  definition robdd_copy where
    "robdd_copy apply_map rev_map b = robdd_apply apply_map rev_map (λb1 b2. (b1  b2)) b robdd_one"

  lemma robdd_copy_correct_full :
  fixes b rev_map apply_map bs
  defines "res  robdd_copy apply_map rev_map b"
  defines "b'  fst res"
  defines "apply_map'  fst (snd res)"
  defines "rev_map'  snd (snd res)"
  assumes invar_rev_map: "rev_map_invar bs rev_map"
      and invar_apply_map: "apply_map_invar (λb1 b2. (b1  b2)) bs bs1 bs2 apply_map"
      and b_invar: "robdd_invar_ext bs1 n b"      
      and bs1_OK: "b. b  bs1  robdd_invar b"
      and bs2_OK: "b. b  bs2  robdd_invar b" "robdd_invar_ids bs2"
  shows "bs'. 
         subrobdds b'  bs  bs'  
         robdd_invar_ext bs' n b' 
         apply_map_invar (λb1 b2. (b1  b2)) bs' bs1 
              (insert robdd_zero (insert robdd_one bs2)) apply_map' 
         rev_map_invar bs' rev_map' 
         (a. robdd_α b' a  (robdd_α b a))"
  proof -

    from bs2_OK have "robdd_invar_ids_leafs bs2"
      apply (rule_tac robdd_invar_ids_leafs_intro)
      apply (simp_all add: robdd_invar_def robdd_invar_ext_def)
    done
    with bs2_OK(2) have "robdd_invar_ids_full bs2" by (simp add: robdd_invar_ids_full_def)
    hence bs2'_invar: "robdd_invar_ids (insert robdd_zero (insert robdd_one bs2))"
      unfolding robdd_invar_ids_full_alt_def by simp 

    from b_invar
    have bs1_invar: "robdd_invar_ids bs1"
      unfolding robdd_invar_ext_def by simp 
   
    from invar_apply_map have
      invar_apply_map': "apply_map_invar (λb1 b2. (b1  b2)) bs bs1 
           (insert robdd_zero (insert robdd_one bs2)) apply_map"
      apply (rule apply_map_invar_extend)
      apply (auto simp add: subset_iff bs1_OK bs2_OK bs2'_invar bs1_invar)
    done

    from robdd_apply_correct_full[OF invar_rev_map invar_apply_map' b_invar _ bs1_OK, of robdd_one]
         res_def[symmetric]
    show ?thesis apply (simp add: robdd_copy_def b'_def[symmetric] apply_map'_def[symmetric]
       rev_map'_def[symmetric])
       by (metis bs2_OK(1) bs2'_invar robdd_invar_simps_leafs)
  qed

  lemma robdd_copy_correct :
  fixes b rev_map apply_map bs
  defines "res  robdd_copy (c_empty ()) rev_map b"
  defines "b'  fst res"
  defines "rev_map'  snd (snd res)"
  assumes invar_rev_map: "rev_map_invar bs rev_map"
      and b_invar: "robdd_invar_ext {b} n b"      
  shows "bs'. 
         subrobdds b'  bs  bs'  
         robdd_invar_ext bs' n b' 
         rev_map_invar bs' rev_map' 
         (a. robdd_α b' a  (robdd_α b a))"
    using res_def[symmetric] 
    using robdd_copy_correct_full [OF invar_rev_map _ b_invar, of "{}" "c_empty ()"]
      apply (simp add: apply_map_invar_def c.empty_correct c.lookup_correct robdd_invar_ids_def
                       b'_def[symmetric] rev_map'_def[symmetric])
      apply (metis b_invar robdd_invar_impl)
    done

  lemma robdd_copy_alt_def :
    "robdd_copy apply_map rev_map b = 
      (case (robdd_to_bool b) of 
         Some f  (robdd_leaf f, apply_map, rev_map)
       | None  (case c_lookup (robdd_get_id b, 1) apply_map of
            Some b3  (b3, apply_map, rev_map)
          | None  (let (l1, r1, var) = robdd_neg_next b in 
                     let (l, apply_map, rev_map) = robdd_copy apply_map rev_map l1 in
                     let (r, apply_map, rev_map) = robdd_copy apply_map rev_map r1 in
                     let (b3, rev_map) = robdd_construct rev_map l var r in
                     let apply_map = c_update (robdd_get_id b, 1) b3 apply_map in
                     (b3, apply_map, rev_map))))"
   proof -
     have bope_neg_intro: 
        "(bool_op_extend (λb1 b2. b1  b2) (robdd_to_bool b) (Some True)) =
         (robdd_to_bool b)" 
        apply (cases "robdd_to_bool b" rule: bool_opt_exhaust)
        apply (simp_all)
     done

     obtain b1_l b1_r v'' b2_l b2_r where 
       next_eq: "robdd_apply_next b robdd_one = (b1_l, b1_r, v'', b2_l, b2_r)" by (metis prod.exhaust)

     from next_eq have b2_eq[simp]: "b2_l = robdd_one" "b2_r = robdd_one"
       by (case_tac[!] b) auto

     show ?thesis
       unfolding robdd_copy_def robdd_apply.simps[of _ _ _ b]
       by (simp split: option.splits add: bope_neg_intro next_eq split_def robdd_neg_next_def)
   qed

  definition restrict_map_invar where
     "restrict_map_invar f bs res_map 
       c_invar res_map 
       (i v b. c_lookup (v, i) res_map = Some b 
          (b'. robdd_id_map bs i = Some b'  b  bs             
                robdd_invar_ext bs (robdd_get_var b') b  
                (a. robdd_α b a  robdd_α b' (a(v := f)))))"

  lemma restrict_map_invar_empty : 
    "restrict_map_invar f bs (c_empty ())"
    unfolding restrict_map_invar_def by (simp add: c.empty_correct c.lookup_correct)

  lemma restrict_map_invar_I :
    "c_invar res_map;
      i v b. c_lookup (v, i) res_map = Some b 
      (b'. robdd_id_map bs i = Some b'  b  bs 
                robdd_invar_ext bs (robdd_get_var b') b  
                (a. robdd_α b a  robdd_α b' (a(v := f)))) 
      restrict_map_invar f bs res_map"
   unfolding restrict_map_invar_def by blast

  lemma restrict_map_invar_D1 :
    "restrict_map_invar f bs res_map  c_invar res_map"
   unfolding restrict_map_invar_def by blast

  lemma restrict_map_invar_D2 :
    "restrict_map_invar f bs res_map;
      c_lookup (v, i) res_map = Some b 
      (b'. robdd_id_map bs i = Some b'  b  bs 
                robdd_invar_ext bs (robdd_get_var b') b  
                (a. robdd_α b a  robdd_α b' (a(v := f))))"
   unfolding restrict_map_invar_def by blast

  fun robdd_restrict where
    "robdd_restrict res_map rev_map f rv b =
     (case b of (robdd_leaf f')  (robdd_leaf f', res_map, rev_map)
             | (robdd_var i l v r)  
        (if (rv < v) then (b, res_map, rev_map) else (
         if (rv = v) then (if f then l else r, res_map, rev_map) else (
         (case c_lookup (rv, i) res_map of
             Some b3  (b3, res_map, rev_map)
           | None  (let (l', res_map, rev_map) = robdd_restrict res_map rev_map f rv l in
                      let (r', res_map, rev_map) = robdd_restrict res_map rev_map f rv r in
                      let (b3, rev_map) = robdd_construct rev_map l' v r' in
                      let res_map = c_update (rv, i) b3 res_map in
                      (b3, res_map, rev_map))                    
        )))))"
  declare robdd_restrict.simps [simp del]

  lemma robdd_restrict_correct_full :
  fixes b f rv rev_map res_map bs
  defines "res  robdd_restrict res_map rev_map f rv b"
  defines "b'  fst res"
  defines "res_map'  fst (snd res)"
  defines "rev_map'  snd (snd res)"
  assumes invar_rev_map: "rev_map_invar bs rev_map"
      and invar_res_map: "restrict_map_invar f bs res_map"
      and b_invar: "robdd_invar_ext bs n b"
      and b_sub: "subrobdds b  bs"      
  shows "bs'. insert b' bs  bs'  
         robdd_invar_ext bs' n b' 
         restrict_map_invar f bs' res_map' 
         rev_map_invar bs' rev_map' 
         (a. robdd_α b' a  (robdd_α b (a(rv := f))))"         
  using invar_rev_map invar_res_map b_invar b_sub
  unfolding b'_def res_map'_def rev_map'_def res_def
  proof (induct b arbitrary: bs n res_map rev_map)
    case (robdd_leaf f')
    thus ?case by (rule_tac exI [where x = bs]) (simp add: robdd_restrict.simps)
  next 
    case (robdd_var i l v r)
    note indhyp_l = robdd_var(1)
    note indhyp_r = robdd_var(2)
    note invar_rev_map = robdd_var(3)
    note invar_res_map = robdd_var(4)
    note b_invar = robdd_var(5)
    note b_sub = robdd_var(6)

    let ?b = "robdd_var i l v r"
    let ?res = "robdd_restrict res_map rev_map f rv ?b"

    from b_invar have b_in_bs: "?b  subrobdds_set bs" unfolding robdd_invar_ext_def by simp
    from rev_map_invar_implies_invar_ids[OF invar_rev_map] 
    have invar_ids_bs: "robdd_invar_ids bs" by simp
    note bs_OK_full = rev_map_invar_implies_invar_bs[OF invar_rev_map]
    have bs_OK: "b. b  bs  robdd_invar b" by (metis bs_OK_full subrobdds_set_mono subsetD)
    have invar_ids_equal_bs: "robdd_invar_ids_equal bs"
      by (rule robdd_invar_ids_equal_intro [OF bs_OK invar_ids_bs])

    have invar_ids_leafs_bs : "robdd_invar_ids_leafs bs"
    proof (rule robdd_invar_ids_leafs_intro[of bs, OF _ invar_ids_bs])
      fix b
      assume "b  bs"
      with bs_OK[of b] have "robdd_invar b" by simp
      thus "robdd_invar_reduced b" unfolding robdd_invar_def robdd_invar_ext_def by simp
    qed 

    from b_invar have invars_greater: "robdd_invar_vars_greater (Suc v) l"  "robdd_invar_vars_greater (Suc v) r"
      by (simp_all add: robdd_invar_ext_def)

    show ?case
    proof (cases "rv < v")
      case True note rv_less = this

      have sem_simp :
         "a bb. robdd_invar_vars_greater (Suc v) bb  
                 robdd_α bb (λx. (x = rv  f)  (x  rv  a x)) = robdd_α bb a"      
        apply (rule_tac robdd_α_invar_greater[of "Suc v"])
        apply (insert rv_less)
        apply (simp_all)
      done
        
      show ?thesis using rv_less b_invar b_sub
        apply (rule_tac exI[where x = bs]) 
        apply (simp add: invar_rev_map invar_res_map robdd_restrict.simps)
        apply (simp add: invars_greater sem_simp)
      done
    next
      case False hence v_le: "v  rv" by simp

      show ?thesis
      proof (cases "rv = v")
        case True note rv_eq [simp] = this

        from invars_greater(2) have r_simp :
           "a. robdd_α r (λx. x  v  a x) = robdd_α r a"      
          apply (rule_tac robdd_α_invar_greater[of "Suc v"])
          apply (simp_all)
        done

        from invars_greater(1) have l_simp :
           "a. robdd_α l (λx. (x  v  a x)) = robdd_α l a"      
          apply (rule_tac robdd_α_invar_greater[of "Suc v"])
          apply (simp_all)
        done

        from b_invar robdd_invar_ext_weaken_var[of bs "Suc v" _ n]
        have "robdd_invar_ext bs n l" "robdd_invar_ext bs n r" by simp_all
        thus ?thesis using b_invar b_sub
          supply map_upd_eq_restrict[simp]  
          apply (rule_tac exI[where x = bs]) 
          apply (simp add: invar_rev_map invar_res_map robdd_restrict.simps)
          apply (simp add: l_simp r_simp subset_iff)
        done
      next
        case False with v_le have v_less: "v < rv" by simp

        show ?thesis 
        proof (cases "c_lookup (rv, i) res_map")
          case (Some b3) note lookup_eq = this

          from robdd_id_map_properties[of bs] invar_ids_equal_bs
          have "robdd_id_map_OK bs (robdd_id_map bs)" by simp
          with robdd_id_map_OK_D[of bs "robdd_id_map bs", OF _ b_in_bs]
          have "robdd_id_map bs i = Some ?b" by simp

          with restrict_map_invar_D2[OF invar_res_map lookup_eq] v_less
          have invar_b3: "robdd_invar_ext bs v b3" and
               b3_in_bs: "b3  bs" and
               sem_b3: "a. robdd_α b3 a = (if a v then robdd_α l (a(rv := f)) else 
                   robdd_α r (a(rv := f)))" by simp_all

          from invar_b3 b_invar have invar_b3': "robdd_invar_ext bs n b3"
            apply (rule_tac robdd_invar_ext_weaken_var[of _ v])
            apply simp_all
          done

          have "a. (λx. (x = rv  f)  (x  rv  a x)) = a (rv := f)"
            by (simp add: fun_eq_iff)
          with lookup_eq 
          show ?thesis using v_less b3_in_bs
            apply (rule_tac exI[where x = bs]) 
            apply (simp add: sem_b3 invar_b3' invar_rev_map invar_res_map robdd_restrict.simps)
          done
        next
          case None note lookup_eq = this

          obtain l' res_map' rev_map' where 
            res_l_eq: "robdd_restrict res_map rev_map f rv l = (l', res_map', rev_map')"
            by (metis prod.exhaust)
          obtain r' res_map'' rev_map'' where 
            res_r_eq: "robdd_restrict res_map' rev_map' f rv r = (r', res_map'', rev_map'')"
            by (metis prod.exhaust)
          obtain b3 rev_map''' where 
            const_eq: "robdd_construct rev_map'' l' v r' = (b3, rev_map''')"
            by (metis prod.exhaust)

          from b_invar b_sub indhyp_l [OF invar_rev_map invar_res_map, of "Suc v"]
          obtain bs' where
             subset_bs': "insert l' bs  bs'" and
             l'_invar: "robdd_invar_ext bs' (Suc v) l'" and
             invar_res_map': "restrict_map_invar f bs' res_map'" and
             invar_rev_map': "rev_map_invar bs' rev_map'" and
             sem_l': "a. robdd_α l' a = (robdd_α l (λb. if b = rv then f else a b))"
            by (simp add: invar_rev_map invar_res_map res_l_eq) blast

          from b_invar have "robdd_invar_ext bs (Suc v) r" by simp
          with l'_invar subset_bs' have "robdd_invar_ext bs' (Suc v) r"
            unfolding robdd_invar_ext_def by simp (metis subrobdds_set_mono2 subsetD)
          with b_sub subset_bs' indhyp_r [OF invar_rev_map' invar_res_map', of "Suc v"]
          obtain bs'' where
             subset_bs'': "insert r' bs'  bs''" and
             r'_invar: "robdd_invar_ext bs'' (Suc v) r'" and
             invar_res_map'': "restrict_map_invar f bs'' res_map''" and
             invar_rev_map'': "rev_map_invar bs'' rev_map''" and
             sem_r': "a. robdd_α r' a = (robdd_α r (λb. if b = rv then f else a b))"
            by (simp add: subset_iff invar_rev_map invar_res_map res_r_eq) blast
          from l'_invar r'_invar subset_bs' subset_bs'' 
          have l'_invar': "robdd_invar_ext bs'' (Suc v) l'"
            unfolding robdd_invar_ext_def by simp (metis subrobdds_set_mono2 subsetD)

          from subset_bs' subset_bs'' have "l'  bs''" "r'  bs''"
            by (simp_all add: subset_iff)

          from robdd_construct_correct [OF invar_rev_map'' l'  bs'' r'  bs''
              l'_invar' r'_invar]
          have b3_invar: "robdd_invar_ext (insert b3 bs'') v b3" and
               invar_rev_map''': "rev_map_invar (insert b3 bs'') rev_map'''" and
               sem_b3: "robdd_α b3 = robdd_α (robdd_var 0 l' v r')"
            by (simp_all add: const_eq) 

          from b3_invar b_invar have b3_invar': "robdd_invar_ext (insert b3 bs'') n b3"
            apply (rule_tac robdd_invar_ext_weaken_var[of _ v])
            apply simp_all
          done

          from subset_bs' subset_bs'' have bs_sub: "bs  insert b3 bs''"
            by (simp add: subset_iff)

          have invar_res_map''':
            "restrict_map_invar f (insert b3 bs'') (c_update (rv, i) b3 res_map'')" 
          proof -
            from b_in_bs subset_bs' subset_bs''
            have b_in': "robdd_var i l v r  subrobdds_set bs''"
              unfolding subrobdds_set_def by (simp add: subset_iff Bex_def) blast

            from robdd_id_map_union [of "{b3}" bs'']
                 rev_map_invar_implies_invar_ids_equal[OF invar_rev_map''']
            have id_map_eq: "robdd_id_map (insert b3 bs'') = robdd_id_map {b3} ++ robdd_id_map bs''" by simp

            from robdd_id_map_properties[of "insert b3 bs''"] b_in'
                 rev_map_invar_implies_invar_ids_equal[OF invar_rev_map''']
                 robdd_id_map_OK_D [of "insert b3 bs''" "robdd_id_map (insert b3 bs'')" ?b]
            have map_id_i: "robdd_id_map (insert b3 bs'') i = Some ?b" by simp
            note c_invar = restrict_map_invar_D1[OF invar_res_map'']
  
            show ?thesis 
            proof (rule restrict_map_invar_I, goal_cases)
              from restrict_map_invar_D1[OF invar_res_map'']
              show "c_invar (c_update (rv, i) b3 res_map'')" by (simp add: c.update_correct)
            next
              case prems: (2 i' v' b')
              note lookup_eq = prems(1)
     
              show ?case
              proof (cases "i' = i  v' = rv")
                case True note iv'_eq = this
                with lookup_eq map_id_i sem_b3 b3_invar v_less show ?thesis
                  by (simp add: c_invar c.update_correct c.lookup_correct
                                sem_l' sem_r' fun_upd_def)
              next
                case False
                with lookup_eq have lookup_eq': "c_lookup (v', i') res_map'' = Some b'"
                  by (auto simp add: c_invar c.lookup_correct c.update_correct)

                from restrict_map_invar_D2[OF invar_res_map'' lookup_eq'] 
                obtain b'' where b''_props:
                  "robdd_id_map bs'' i' = Some b''" "b'  bs''"
                  "robdd_invar_ext bs'' (robdd_get_var b'') b'"
                  "a. robdd_α b' a = robdd_α b'' (a(v' := f))" by auto
 
               show ?thesis
                 apply (rule_tac exI[where x = b''])
                 apply (simp add: id_map_eq map_add_Some_iff b''_props)
                 apply (insert b3_invar b''_props(3))
                 apply (simp add: robdd_invar_ext_def)
                 done             
              qed
            qed
          qed

          from robdd_restrict.simps[of res_map rev_map f rv ?b]
          show ?thesis using v_less 
            apply (rule_tac exI[where x = "insert b3 bs''"])
            apply (simp add: lookup_eq res_l_eq res_r_eq const_eq invar_rev_map'''
                             sem_b3 sem_l' sem_r' b3_invar' bs_sub invar_res_map''')
          done
        qed
      qed
    qed
  qed


end


subsection ‹Semantics on lists›

text ‹BDDs represent boolean expression. I.e. they are functions from assignments to 
  \texttt{True} or \texttt{False}. Here, assignments are represented by functions from
  variable indices to the values of these Boolean variables. While this reprentation of 
  is convenient for proofs, a representation based on lists is more convinient for execution.›

definition list_to_assignment_set :: "bool option list  (nat  bool) set" where
"list_to_assignment_set l = {a . (v < length l. (f. l ! v = Some f  a v = f))}"

definition shift_assignment where
  "shift_assignment (b::bool) a = (λv. case v of 0  b | Suc v'  a v')" 

lemma inj_shift_assignement :
  "inj_on (shift_assignment b) S"
unfolding inj_on_def shift_assignment_def
by (simp add: fun_eq_iff split: nat.splits)

lemma list_to_assignment_set_None_simp [simp] :
  "list_to_assignment_set (None # l) = 
   list_to_assignment_set (Some True # l)  list_to_assignment_set (Some False # l)"
unfolding list_to_assignment_set_def
apply (simp add: set_eq_iff less_Suc_eq_0_disj 
            del: all_simps add: all_simps[symmetric])
apply (simp add: all_conj_distrib)
apply (intro allI iffI)
apply simp
apply (elim disjE conjE)
apply simp_all
done
 
lemma list_to_assignment_set_simps [simp]: 
  "list_to_assignment_set [] = UNIV" (is ?T1)
  "list_to_assignment_set (Some b # l) = (shift_assignment b) ` (list_to_assignment_set l)" (is "?T3 b")
proof -
  show ?T1 unfolding list_to_assignment_set_def by simp
next
  show "?T3 b"
    unfolding list_to_assignment_set_def 
    apply (simp add: set_eq_iff less_Suc_eq_0_disj shift_assignment_def 
                  del: all_simps add: all_simps[symmetric])
    apply (simp add: all_conj_distrib image_iff)
    apply (intro allI iffI)
    apply (rule_tac x = "λv. x (Suc v)" in exI)
    apply (simp add: fun_eq_iff split: nat.split)
    apply auto    
    done
qed


lemma infinite_list_to_assignment_set :
  "¬(finite (list_to_assignment_set l))"
proof (induct l)
  case Nil note l_eq = this

  have inf_UNIV: "¬(finite (UNIV :: (nat  bool) set))"
  proof (rule notI)
    assume fin_UNIV: "finite (UNIV :: (nat  bool) set)"
    from finite_fun_UNIVD1[OF fin_UNIV] 
    show False by simp
  qed
  thus ?case by simp
next
  case (Cons bo l')
  note ind_hyp = Cons

  obtain b where sub_b: "list_to_assignment_set (Some b # l')  list_to_assignment_set (bo # l')"
    by (cases bo) auto

  have not_fin_b: "¬(finite (list_to_assignment_set (Some b # l')))"
  proof (rule notI)
    assume "finite (list_to_assignment_set (Some b # l'))"
    hence "finite (list_to_assignment_set l')"
      apply (simp) apply (rule finite_imageD [of "shift_assignment b"])
      apply (simp_all add: inj_shift_assignement)
    done
    with ind_hyp show False by simp
  qed
  from finite_subset[OF sub_b] not_fin_b
  show ?case by blast
qed

lemma list_to_assignment_set_not_empty :
  "(list_to_assignment_set l)  {}"
by (metis finite.emptyI infinite_list_to_assignment_set)

fun robdd_list_α where
   "robdd_list_α (robdd_leaf f) n l = f"
 | "robdd_list_α (robdd_var i l v r) n [] = False"
 | "robdd_list_α (robdd_var i l v r) n (bo # bs) =
     (if n = v then 
        (case bo of None  robdd_list_α l (Suc n) bs  robdd_list_α r (Suc n) bs
                  | Some True  robdd_list_α l (Suc n) bs
                  | Some False  robdd_list_α r (Suc n) bs) 
      else (robdd_list_α (robdd_var i l v r) (Suc n) bs))"

lemma robdd_list_α_correct_aux :
assumes invar: "robdd_invar_vars_greater n b" "robdd_invar_reduced b"
shows "robdd_list_α b n l  (a  (list_to_assignment_set l). robdd_α b (λv. a (v - n)))"
using invar
proof (induct b n l rule: robdd_list_α.induct)
  case (1 f n l)
  with list_to_assignment_set_not_empty[of l] show ?case by auto
next
  case prems: (2 i ll v rr n)
  note invar = prems(1,2)

  from invar have "robdd_α ll  robdd_α rr"
    by (metis robdd_equiv_alt_def_full robdd_invar_reduced.simps(2) 
              robdd_invar_vars_greater.simps(2) robdd_invar_vars_impl)
  then obtain a where a_sem_neq: "robdd_α ll a  robdd_α rr a" by (auto simp add: fun_eq_iff)

  define aa where "aa v = a (v + n)" for v
  from invar(1) have ll_sem: "b. robdd_α ll (λv'. (aa(v - n := b)) (v' - n)) = robdd_α ll a"
    apply (rule_tac robdd_α_invar_greater [of "Suc v"]) 
    apply (simp_all add: aa_def)
    apply auto
    done
  from invar(1) have rr_sem: "b. robdd_α rr (λv'. (aa(v - n := b)) (v' - n)) = robdd_α rr a"
    apply (rule_tac robdd_α_invar_greater [of "Suc v"]) 
    apply (simp_all add: aa_def)
    apply auto
    done
    
  show ?case
  proof (cases "robdd_α ll a")
    case True with a_sem_neq rr_sem show ?thesis 
      apply (simp)
      apply (rule_tac exI[where x = "aa(v-n := False)"]) 
      apply simp
      done
  next
    case False with a_sem_neq ll_sem show ?thesis 
      apply (simp)
      apply (rule_tac exI[where x = "aa(v-n := True)"]) 
      apply simp
      done
  qed
next
  case prems: (3 i ll v rr n b bs)

  note invar = prems(6,7)
  hence invar_rr: "robdd_invar_vars_greater (Suc n) rr" and red_ll: "robdd_invar_reduced ll"
    and invar_ll: "robdd_invar_vars_greater (Suc n) ll" and red_rr: "robdd_invar_reduced rr"
    and invar_n: "n  v  robdd_invar_vars_greater (Suc n) (robdd_var i ll v rr)"
    and n_le: "n  v"
  using robdd_invar_vars_greater___weaken [of "Suc v" _ "Suc n"] by simp_all

  note indhyp_1 = prems(1)[OF _ _ invar_ll red_ll]
  note indhyp_2 = prems(2)[OF _ _ invar_rr red_rr]
  note indhyp_3 = prems(3)[of True, OF _ _ _ invar_ll red_ll, simplified]
  note indhyp_4 = prems(4)[of False, OF _ _ _ invar_rr red_rr, simplified]
  note indhyp_5 = prems(5)[OF _ invar_n invar(2), simplified]

  from invar_ll have ll_sem: "a b. robdd_α ll (λv. case_nat b a (v - n)) = robdd_α ll 
                                     (λv. a (v - Suc n))"
    apply (rule_tac robdd_α_invar_greater [of "Suc n"]) 
    apply (simp_all split: nat.splits)
    apply (metis diff_Suc nat.case(2))
    done

  from invar_rr have rr_sem: "a b. robdd_α rr (λv. case_nat b a (v - n)) = robdd_α rr 
                                     (λv. a (v - Suc n))"
    apply (rule_tac robdd_α_invar_greater [of "Suc n"]) 
    apply (simp_all split: nat.splits)
    apply (metis diff_Suc nat.case(2))
    done

  show ?case
  proof (cases "n = v")
    case False with n_le have n_less: "n < v" by simp
    hence "v - n = Suc (v - (Suc n))" by simp
    with indhyp_5 n_less
    show ?thesis 
      apply (simp add: Ball_def all_conj_distrib del: Suc_diff)
      apply (cases b)
      apply (simp_all add: image_iff Bex_def ex_disj_distrib all_conj_distrib imp_conjR
                       shift_assignment_def imp_ex all_simps(6)[symmetric]
                       ll_sem rr_sem split: nat.split
                  del: ex_simps all_simps Suc_diff)
      
      
    done
  next
    case True note n_eq[simp] = this

    from indhyp_1 indhyp_2 indhyp_3 indhyp_4
    show ?thesis apply (simp add: Ball_def split: option.splits bool.splits)  
      apply (simp_all add: image_iff Bex_def ex_disj_distrib all_conj_distrib imp_conjR
                       shift_assignment_def imp_ex all_simps(6)[symmetric]
                       ll_sem[unfolded n_eq] rr_sem[unfolded n_eq] 
                  del: ex_simps all_simps)
    done
  qed
qed

lemma robdd_list_α_correct:
assumes b_OK: "robdd_invar_vars b" "robdd_invar_reduced b"
shows "robdd_list_α b 0 l  (a  (list_to_assignment_set l). robdd_α b a)"
using robdd_list_α_correct_aux [of 0 b] b_OK unfolding robdd_invar_vars_def by simp


fun robdd_iteratei where
  "robdd_iteratei n ac (robdd_leaf f) = (if f then set_iterator_sng ac else set_iterator_emp)" |
  "robdd_iteratei n ac (robdd_var i l v r) = 
   (set_iterator_union (robdd_iteratei (Suc v) ((Some True) # ((replicate (v-n) None) @ ac)) l)
                       (robdd_iteratei (Suc v) ((Some False) # ((replicate (v-n) None) @ ac)) r))"

(* TODO: Prove correctness of this iterator *)      


end

Theory Locale_Code_Ex

section ‹Example for locale-code›
theory Locale_Code_Ex
imports 
  Locale_Code   
  "../../Lib/Code_Target_ICF"
begin

definition [simp, code del]: "NOCODE  id"

locale test = 
  fixes a b :: nat
  assumes "a=b"
begin
  text ‹Mutually recursive functions›
  fun g and f where
    "g 0 = NOCODE a"
  | "g (Suc n) = a + n + f n"
  | "f 0 = a+b"
  | "f (Suc n) = a + f n + b * f n + g n"

  text ‹Various definitions, depending on more or less parameters›
  definition "k x  b + x :: nat"
  definition "j x y  NOCODE x + y + f x :: nat"
  definition "i x y  x + y :: nat"
  definition "h x y  a+x+k y+i x y+j x y"

  lemmas "defs" = k_def j_def i_def h_def g.simps f.simps 

  lemma j_alt: "j x y  f x + y + x" unfolding j_def by (simp add: ac_simps)

  lemma g_alt:
    "g 0 = a"
    "g (Suc n) = f n + n + a"
    by (auto simp: ac_simps)


  definition "c  a + b"

  local_setup Locale_Code.lc_decl_eq @{thms j_alt}
  local_setup Locale_Code.lc_decl_eq @{thms g_alt}

end

text ‹Conflicting constant name›
definition "h_zero_zero  True"

setup Locale_Code.open_block
  text ‹Various interpretations, with and without constructor patterns 
    and free variables›
  interpretation i0: test 0 0 apply unfold_locales by auto
  interpretation i1: test "Suc n" "Suc n" apply unfold_locales by auto
  interpretation i2: test 1 1 apply unfold_locales by auto
  interpretation i3: test 5 5 apply unfold_locales by auto
  interpretation i4: test "snd (x,3)" "1+2" apply unfold_locales by auto

  interpretation i5: test "i3.c" "i3.c" by unfold_locales simp

  text ‹Setup some alternative equations›
  lemma i0_f_pat: 
    "i0.f 0 = 0"
    "i0.f (Suc n) = i0.f n + i0.g n"
    by simp_all

  lemma i0_h_pat: "i0.h x y = x+i0.k y+i0.i x y+i0.j x y" 
    unfolding i0.h_def by auto

  declare [[ lc_add "i0.f" i0_f_pat and "i0.h" i0_h_pat]]
setup Locale_Code.close_block

definition "foo x y  i0.h x y + i1.h x x y + i2.h x y + i3.h x y 
  + i4.h TYPE(bool) h_zero_zero x y + i5.h x y"

definition "bar x y  i0.f x + i1.f x y + i2.f x + i3.f y 
  + i4.f TYPE(bool) False x + i5.f y"

code_thms foo
code_thms bar

text ‹value›
value "foo 3 4"
value "bar 3 4"

text ‹eval-tactic›
lemma "foo 3 4 = 34578" by eval
lemma "bar 3 4 = 354189" by eval

text ‹Exported code›
export_code foo bar checking SML
export_code foo bar checking OCaml?
export_code foo bar checking Haskell?
export_code foo bar checking Scala

text ‹Inlined code›
ML_val @{code foo} (@{code nat_of_integer} 3) (@{code nat_of_integer} 4);
  @{code bar} (@{code nat_of_integer} 3) (@{code nat_of_integer} 4);

end

Theory DatRef

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Deprecated: Data Refinement for the While-Combinator}›
theory DatRef
imports 
  Main 
  "HOL-Library.While_Combinator"
begin
text_raw ‹\label{thy:DatRef}›

text ‹
  Note that this theory is deprecated. For new developments, the refinement 
  framework (Refine-Monadic entry of the AFP) should be used.
›

text ‹
  In this theory, a data refinement framework for 
  non-deterministic while-loops is developed. The refinement is based on
  showing simulation w.r.t. an abstraction function.
  The case of deterministic while-loops is explicitely handled, to
  support proper code-generation using the While-Combinator.
  
  Note that this theory is deprecated. For new developments, the refinement 
  framework (Refine-Monadic entry of the AFP) should be used.
›

(* TODO-LIST and ideas
  - Model nondeterministic algorithms by their step relation, and show refinement stuff for this (more general) model (c.f. dpn-pre^* formalization)
    Then, the nondeterministic while-loop would be a special case.

*)


text ‹
  A nondeterministic while-algorithm is described by a set of states, a 
  continuation condition, a step relation, a set of possible initial 
  states and an invariant.
›

  ― ‹Encapsulates a while-algorithm and its invariant›
record 'S while_algo =
  ― ‹Termination condition›
  wa_cond :: "'S set"
  ― ‹Step relation (nondeterministic)›
  wa_step :: "('S × 'S) set"
  ― ‹Initial state (nondeterministic)›
  wa_initial :: "'S set"
  ― ‹Invariant›
  wa_invar :: "'S set"
  
text ‹
  A while-algorithm is called {\em well-defined} iff the invariant holds for 
  all reachable states and the accessible part of the step-relation is
  well-founded.
›
  ― ‹Conditions that must hold for a well-defined while-algorithm›
locale while_algo =
  fixes WA :: "'S while_algo"

  ― ‹A step must preserve the invariant›
  assumes step_invar: 
    " swa_invar WA; swa_cond WA; (s,s')wa_step WA   s'wa_invar WA"
  ― ‹Initial states must satisfy the invariant›
  assumes initial_invar: "wa_initial WA  wa_invar WA"
  ― ‹The accessible part of the step relation must be well-founded›
  assumes step_wf: 
    "wf { (s',s). swa_invar WA  swa_cond WA  (s,s')wa_step WA }"

text ‹
  Next, a refinement relation for while-algorithms is defined.
  Note that the involved while-algorithms are not required to
  be well-defined. Later, some lemmas to transfer well-definedness
  along refinement relations are shown.

  Refinement involves a concrete algorithm, an abstract algorithm and an 
  abstraction function. In essence, a refinement establishes a simulation
  of the concrete algorithm by the abstract algorithm w.r.t. the abstraction 
  function.
›

locale wa_refine = 
  ― ‹Concrete algorithm›
  fixes WAC :: "'C while_algo"
  ― ‹Abstract algorithm›
  fixes WAA :: "'A while_algo"

  ― ‹Abstraction function›
  fixes α :: "'C  'A"

  ― ‹Condition implemented correctly: The concrete condition must be stronger 
      than the abstract one. Intuitively, this ensures that the concrete loop
      will not run longer than the abstract one that it is simulated by.›
  assumes cond_abs: " swa_invar WAC; swa_cond WAC   α s  wa_cond WAA"

  ― ‹Step implemented correctly: The abstract step relation must simulate the 
      concrete step relation›
  assumes step_abs: " swa_invar WAC; swa_cond WAC; (s,s')wa_step WAC  
                       (α s, α s')wa_step WAA"
  ― ‹Initial states implemented correctly: The abstractions of the concrete
      initial states must be abstract initial states.›
  assumes initial_abs: "α ` wa_initial WAC  wa_initial WAA"
  ― ‹Invariant implemented correctly: The concrete invariant must be stronger
        then the abstract invariant.
        Note that, usually, the concrete invariant will be of the 
        form @{term "I_add  {s. α s  wa_invar WAA}"}, where @{term I_add} are
        the additional invariants added by the concrete algorithm.›
  assumes invar_abs: "α ` wa_invar WAC  wa_invar WAA"
begin

  lemma initial_abs': "swa_initial WAC  α s  wa_initial WAA"
    using initial_abs by auto

  lemma invar_abs': "swa_invar WAC  α s  wa_invar WAA"
    using invar_abs by auto

end

― ‹Given a concrete while-algorithm and a well-defined abstract 
  while-algorithm, this lemma shows refinement and 
  well-definedness of the concrete while-algorithm.

  Assuming well-definedness of the abstract algorithm and refinement,
  some proof-obligations for well-definedness of the concrete algorithm can be
  discharged automatically.

  For this purpose, the invariant is split into a concrete and an abstract 
  part. The abstract part claims that the abstraction of a state satisfies 
  the abstract invariant. The concrete part makes some additional claims
  about a valid concrete state. Then, after having shown refinement, the 
  assumptions that the abstract part of the invariant is preserved, can
  be discharged automatically.›
lemma wa_refine_intro:
  fixes condc :: "'C set" and 
        stepc :: "('C×'C) set" and 
        initialc :: "'C set" and 
        invar_addc :: "'C set"
  fixes WAA :: "'A while_algo"
  fixes α :: "'C  'A"
  assumes "while_algo WAA"

  ― ‹The concrete step preserves the concrete part of the invariant›
  assumes step_invarc: 
    "!!s s'.  sinvar_addc; scondc; α s  wa_invar WAA; (s,s')stepc  
               s'invar_addc"
  ― ‹The concrete initial states satisfy the concrete part of the invariant›
  assumes initial_invarc: "initialc  invar_addc"

  ― ‹Condition implemented correctly›
  assumes cond_abs: 
    "!!s.  sinvar_addc; α s  wa_invar WAA; scondc   α s  wa_cond WAA"
  ― ‹Step implemented correctly›
  assumes step_abs: 
    "!!s s'.  sinvar_addc; scondc; α s  wa_invar WAA; (s,s')stepc  
              (α s, α s')wa_step WAA"
  ― ‹Initial states implemented correctly›
  assumes initial_abs: "α ` initialc  wa_initial WAA"

  ― ‹Concrete while-algorithm: The invariant is separated into a concrete and
      an abstract part›
  defines "WAC ==  
   wa_cond=condc, 
   wa_step=stepc, 
   wa_initial=initialc, 
   wa_invar=(invar_addc  {s. α s wa_invar WAA}) "

  shows 
    "while_algo WAC  
     wa_refine WAC WAA α" (is "?T1  ?T2")
proof
  interpret waa: while_algo WAA by fact
  show G1: "?T1"
    apply (unfold_locales)
    apply (simp_all add: WAC_def)
    apply safe
    apply (blast intro!: step_invarc)

    apply (frule (3) step_abs)
    apply (frule (2) cond_abs)
    apply (erule (2) waa.step_invar)

    apply (erule rev_subsetD[OF _ initial_invarc])

    apply (insert initial_abs waa.initial_invar) [1]
    apply blast

    apply (rule_tac 
      r="inv_image { (s',s). swa_invar WAA 
                      swa_cond WAA 
                      (s,s')wa_step WAA } α" 
      in wf_subset)
    apply (simp add: waa.step_wf)
    apply (auto simp add: cond_abs step_abs) [1]
    done
  show ?T2
    apply (unfold_locales)
    apply (auto simp add: cond_abs step_abs initial_abs WAC_def)
    done
qed

  ― ‹After refinement has been shown, this lemma transfers
        the well-definedness property up the refinement chain.
        Like in @{thm [source] wa_refine_intro}, some proof-obligations can
        be discharged by assuming refinement and well-definedness of the 
        abstract algorithm.›
lemma (in wa_refine) wa_intro:
  ― ‹Concrete part of the invariant›
  fixes addi :: "'C set"
  ― ‹The abstract algorithm is well-defined›
  assumes "while_algo WAA"
  ― ‹The invariant can be split into concrete and abstract part›
  assumes icf: "wa_invar WAC = addi  {s. α s  wa_invar WAA}"

  ― ‹The step-relation preserves the concrete part of the invariant›
  assumes step_addi: 
    "!!s s'.  saddi; swa_cond WAC; α s  wa_invar WAA; 
               (s,s')wa_step WAC 
               s'addi"

  ― ‹The initial states satisfy the concrete part of the invariant›
  assumes initial_addi: "wa_initial WAC  addi"

  shows 
    "while_algo WAC"
proof -
  interpret waa: while_algo WAA by fact
  show ?thesis
    apply (unfold_locales)
    apply (subst icf)
    apply safe
    apply (simp only: icf)
    apply safe
    apply (blast intro!: step_addi)

    apply (frule (2) step_abs)
    apply (frule (1) cond_abs)
    apply (simp only: icf)
    apply clarify
    apply (erule (2) waa.step_invar)

    apply (simp add: icf)
    apply (rule conjI)
    apply (erule rev_subsetD[OF _ initial_addi])
    apply (insert initial_abs waa.initial_invar) [1]
    apply blast

    apply (rule_tac 
      r="inv_image { (s',s). swa_invar WAA 
                     swa_cond WAA 
                     (s,s')wa_step WAA } α" 
      in wf_subset)
    apply (simp add: waa.step_wf)
    apply (auto simp add: cond_abs step_abs icf) [1]
    done
qed

text ‹
  A special case of refinement occurs, if the concrete condition implements the
  abstract condition precisely. In this case, the concrete algorithm will run 
  as long as the abstract one that it is simulated by. This allows to 
  transfer properties of the result from the abstract algorithm to the 
  concrete one.
›

― ‹Precise refinement›
locale wa_precise_refine = wa_refine +
  constrains α :: "'C  'A"
  assumes cond_precise: 
    "s. swa_invar WAC  α swa_cond WAA  swa_cond WAC"
begin
  ― ‹Transfer correctness property›
  lemma transfer_correctness:
    assumes A: "s. swa_invar WAA  swa_cond WAA  P s"
    shows "sc. scwa_invar WAC  scwa_cond WAC  P (α sc)"
    using A cond_abs invar_abs cond_precise by blast
end
    
text ‹Refinement as well as precise refinement is reflexive and transitive›

lemma wa_ref_refl: "wa_refine WA WA id"
  by (unfold_locales) auto

lemma wa_pref_refl: "wa_precise_refine WA WA id"
  by (unfold_locales) auto

lemma wa_ref_trans: 
  assumes "wa_refine WC WB α1"
  assumes "wa_refine WB WA α2"
  shows "wa_refine WC WA (α2α1)"
proof -
  interpret r1: wa_refine WC WB α1 by fact
  interpret r2: wa_refine WB WA α2 by fact

  show ?thesis (* Cool, everything by auto! *)
    apply unfold_locales
    apply (auto simp add: 
      r1.invar_abs' r2.invar_abs'
      r1.cond_abs r2.cond_abs
      r1.step_abs r2.step_abs
      r1.initial_abs' r2.initial_abs')
    done
qed

lemma wa_pref_trans: 
  assumes "wa_precise_refine WC WB α1"
  assumes "wa_precise_refine WB WA α2"
  shows "wa_precise_refine WC WA (α2α1)"
proof -
  interpret r1: wa_precise_refine WC WB α1 by fact
  interpret r2: wa_precise_refine WB WA α2 by fact
  
  show ?thesis
    apply intro_locales
    apply (rule wa_ref_trans)
    apply (unfold_locales)
    apply (auto simp add: r1.invar_abs' r2.invar_abs' 
                          r1.cond_precise r2.cond_precise)
    done
qed

text ‹
  A well-defined while-algorithm is {\em deterministic}, iff
  the step relation is a function and there is just one 
  initial state. Such an algorithm is suitable for direct implementation 
  by the while-combinator.

  For deterministic while-algorithm, an own record is defined, as well as a
  function that maps it to the corresponding record for non-deterministic
  while algorithms. This makes sense as the step-relation may then be modeled
  as a function, and the initial state may be modeled as a single state rather 
  than a (singleton) set of states.
›

record 'S det_while_algo =
  ― ‹Termination condition›
  dwa_cond :: "'S  bool"
  ― ‹Step function›
  dwa_step :: "'S  'S"
  ― ‹Initial state›
  dwa_initial :: "'S"
  ― ‹Invariant›
  dwa_invar :: "'S set"
  
  ― ‹Maps the record for deterministic while-algo to the corresponding record for
      the non-deterministic one›
definition "det_wa_wa DWA ==  
  wa_cond={s. dwa_cond DWA s}, 
  wa_step={(s,dwa_step DWA s) | s. True}, 
  wa_initial={dwa_initial DWA},
  wa_invar = dwa_invar DWA"

  ― ‹Conditions for a deterministic while-algorithm›
locale det_while_algo = 
  fixes WA :: "'S det_while_algo"
  ― ‹The step preserves the invariant›
  assumes step_invar: 
    " sdwa_invar WA; dwa_cond WA s   dwa_step WA s  dwa_invar WA"
  ― ‹The initial state satisfies the invariant›
  assumes initial_invar: "dwa_initial WA  dwa_invar WA"
  ― ‹The relation made up by the step-function is well-founded.›
  assumes step_wf: 
    "wf { (dwa_step WA s,s) | s. sdwa_invar WA  dwa_cond WA s }"

begin
  lemma is_while_algo: "while_algo (det_wa_wa WA)"
    apply (unfold_locales)
    apply (auto simp add: det_wa_wa_def step_invar initial_invar)
    apply (insert step_wf)
    apply (erule_tac P=wf in back_subst)
    apply auto
    done

end

lemma det_while_algo_intro:
  assumes "while_algo (det_wa_wa DWA)" 
  shows "det_while_algo DWA"
proof -
  interpret while_algo "(det_wa_wa DWA)" by fact

  show ?thesis using step_invar initial_invar step_wf
    apply (unfold_locales)
    apply (unfold det_wa_wa_def)
    apply auto
    apply (erule_tac P=wf in back_subst)
    apply auto
    done
    
qed

― ‹A deterministic while-algorithm is well-defined, if and only if the 
    corresponding non-deterministic while-algorithm is well-defined›
theorem dwa_is_wa: 
  "while_algo (det_wa_wa DWA)  det_while_algo DWA"
  using det_while_algo_intro det_while_algo.is_while_algo by auto


definition (in det_while_algo) 
  "loop == (while (dwa_cond WA) (dwa_step WA) (dwa_initial WA))"

― ‹Proof rule for deterministic while loops›
lemma (in det_while_algo) while_proof:
  assumes inv_imp: "s. sdwa_invar WA; ¬ dwa_cond WA s  Q s"
  shows "Q loop"
  apply (unfold loop_def)
  apply (rule_tac P="λx. xdwa_invar WA" and 
                  r="{ (dwa_step WA s,s) | s. sdwa_invar WA  dwa_cond WA s }" 
                  in while_rule)
  apply (simp_all add: step_invar initial_invar step_wf inv_imp)
  done

  ― ‹This version is useful when using transferred correctness lemmas›
lemma (in det_while_algo) while_proof':
  assumes inv_imp: 
    "s. swa_invar (det_wa_wa WA)  swa_cond (det_wa_wa WA)  Q s"
  shows "Q loop"
  using inv_imp
  apply (simp add: det_wa_wa_def)
  apply (blast intro: while_proof)
  done

lemma (in det_while_algo) loop_invar:
  "loop  dwa_invar WA"
  by (rule while_proof) simp


end

Theory SetAbstractionIterator

(*  Title:       Iterators over Representations of Finite Sets
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section ‹\isaheader{Iterators over Representations of Finite Sets}›
theory SetAbstractionIterator
imports Main SetIterator 
begin

text ‹Sometimes, an iterator does not iterate over an abstract set directly. 
 Especialy, if datastructures that are composed of several concrete datastructures 
 for maps or sets are involved, it might be interesting to iterate over 
 representations of values instead of the abstract values. This leads to the following construct.› 

locale set_iterator_abs_genord =
  fixes α :: "'xc  'xa"
    and invar :: "'xc  bool"  
    and iti::"('xc,) set_iterator"
    and S0::"'xa set" 
    and R::"'xa  'xa  bool"
  assumes foldli_transform:
    "lc. (xc  set lc. invar xc)  
          distinct (map α lc)  S0 = set (map α lc)  
          sorted_wrt R (map α lc)  iti = foldli lc"
begin
  text ‹In the simplest case, the function used for iteration does not depend on
    the representation, but just the abstract values. In this case, the \emph{normal} iterators
    can be used with an adapted function.› 
  lemma remove_abs :
    assumes f_OK: "xc. invar xc  α xc  S0  fc xc = fa (α xc)"
        and it_OK: "iti. set_iterator_genord iti S0 R  P (iti c fa σ0)"
    shows "P (iti c fc σ0)"
  proof -
    from foldli_transform obtain lc where 
          lc_invar: "xc. xc  set lc  invar xc" 
      and α_props: "distinct (map α lc)" "S0 = set (map α lc)" 
                   "sorted_wrt R (map α lc)" 
      and iti_eq: "iti = foldli lc" by blast

    from α_props have "set_iterator_genord (foldli (map α lc)) S0 R"
      by (rule_tac set_iterator_genord_I [of "map α lc"]) simp_all
    with it_OK have P_OK: "P (foldli (map α lc) c fa σ0)" by blast

    from lc_invar f_OK[unfolded α_props(2)]
    have "foldli (map α lc) c fa σ0 = foldli lc c fc σ0"
      by (induct lc arbitrary: σ0) simp_all
 
    with P_OK iti_eq show ?thesis by simp
  qed

  text ‹In general, one needs the representation, though. Even in this case,
    the construct can be reduced to standard iterators.›
  lemma remove_abs2 :
    "S0'. set_iterator_genord iti S0' (λx y. R (α x) (α y)) 
           inj_on α S0'  α ` S0' = S0  (x  S0'. invar x)"
  proof -
    from foldli_transform obtain lc where 
          lc_invar: "xc. xc  set lc  invar xc" 
      and α_props: "distinct (map α lc)" "S0 = set (map α lc)" 
                   "sorted_wrt R (map α lc)" 
      and iti_eq: "iti = foldli lc" by blast
    from α_props have it': "set_iterator_genord iti (set lc) (λx y. R (α x) (α y))"
      apply (rule_tac set_iterator_genord_I [of lc])  
      apply (simp_all add: distinct_map sorted_wrt_map iti_eq)
    done

    from α_props show ?thesis
      apply (rule_tac exI[where x = "set lc"])
      apply (simp add: lc_invar distinct_map it')
    done
  qed

  text ‹Let's now derive the inference rules for iterators over representations.›

  lemma iteratei_abs_simple_rule_P:
  assumes f_OK: "xc. invar xc  α xc  S0  f xc = f' (α xc)"
  assumes pre :
      "I S0 σ0"
      "S σ x.  c σ; x  S; I S σ; S  S0; 
                 yS - {x}. R x y; yS0 - S. R y x 
                  I (S - {x}) (f' x σ)"
      "σ. I {} σ  P σ"
      "σ S.  S  S0; S  {}; ¬ c σ; I S σ;
               xS. yS0-S. R y x   P σ"
    shows "P (iti c f σ0)"
    apply (rule remove_abs[of f f' P c σ0])
    apply (simp add: f_OK)
    apply (erule set_iterator_genord.iteratei_rule_P [of _ S0 R I])
    apply (simp_all add: pre)
  done

  lemma iteratei_abs_simple_rule_insert_P:
  assumes f_OK: "xc. invar xc  α xc  S0  f xc = f' (α xc)"
  assumes pre :
      "I {} σ0"
      "S σ x.  c σ; x  S0 - S; I S σ; S  S0; y(S0 - S) - {x}. R x y;
                 yS. R y x 
                   I (insert x S) (f' x σ)"
      "σ. I S0 σ  P σ"
      "σ S.  S  S0; S  S0; 
              ¬ (c σ); I S σ; xS0-S. yS. R y x   P σ"
  shows "P (iti c f σ0)"
    apply (rule remove_abs[of f f' P c σ0])
    apply (simp add: f_OK)
    apply (erule set_iterator_genord.iteratei_rule_insert_P [of _ S0 R I])
    apply (simp_all add: pre)
  done

  lemma iteratei_abs_rule_P:
  assumes pre :
      "I S0 σ0"
      "S σ x.  c σ; invar x; α x  S; I S σ; S  S0; 
                 yS - {α x}. R (α x) y; yS0 - S. R y (α x) 
                  I (S - {α x}) (f x σ)"
      "σ. I {} σ  P σ"
      "σ S.  S  S0; S  {}; ¬ c σ; I S σ;
               xS. yS0-S. R y x   P σ"
    shows "P (iti c f σ0)"
  proof -
    obtain S0' where S0'_props: "set_iterator_genord iti S0' (λx y. R (α x) (α y))"
       "inj_on α S0'" "S0 = α ` S0'" "x. x  S0'  invar x" by (metis remove_abs2)
  
    show ?thesis
    proof (rule set_iterator_genord.iteratei_rule_P[OF S0'_props(1), of "λS σ. I (α ` S) σ" σ0 c], goal_cases)
      case 1
      thus ?case using S0'_props pre by simp   
    next
      case 3 thus ?case using S0'_props pre by simp   
    next
      case prems: (2 S σ x)

      from prems S0'_props have inv_x: "invar x" by blast
      from prems(4) have subs_alpha: "α ` S  α ` S0'" by auto
      from S0'_props prems(2,4)
      have diff_alpha: "α ` S - {α x} = α ` (S - {x})" "α ` S0' - α ` S = α ` (S0' - S)"
       by (auto simp add: inj_on_def subset_iff Ball_def)

      show ?case 
        using pre(2)[of σ x "α ` S"] S0'_props(3)  
        by (simp add: inv_x prems subs_alpha diff_alpha)
    next
      case prems: (4 σ S)
      show ?case
        using pre(4)[of "α ` S" σ] prems S0'_props
        by auto
    qed
  qed

  lemma iteratei_abs_rule_insert_P:
  assumes pre :
      "I {} σ0"
      "S σ x.  c σ; invar x; α x  S0 - S; I S σ; S  S0; 
                 y(S0 - S) - {α x}. R (α x) y; yS. R y (α x) 
                  I (insert (α x) S) (f x σ)"
      "σ. I S0 σ  P σ"
      "σ S.  S  S0; S  S0; ¬ c σ; I S σ;
               xS0-S. yS. R y x   P σ"
    shows "P (iti c f σ0)"
  proof -
    obtain S0' where S0'_props: "set_iterator_genord iti S0' (λx y. R (α x) (α y))"
       "inj_on α S0'" "S0 = α ` S0'" "x. x  S0'  invar x" by (metis remove_abs2)
  
    show ?thesis
    proof (rule set_iterator_genord.iteratei_rule_insert_P[OF S0'_props(1), of "λS σ. I (α ` S) σ" σ0 c], goal_cases)
      case 1
      thus ?case using S0'_props pre by simp   
    next
      case 3
      thus ?case using S0'_props pre by simp   
    next
      case prems: (2 S σ x)

      from prems S0'_props have inv_x: "invar x" by blast
      from prems(4) have subs_alpha: "α ` S  α ` S0'" by auto
      from S0'_props prems(2,4)
      have diff_alpha: "α ` (S0' - S) - {α x} = α ` ((S0' - S) - {x})" "α ` S0' - α ` S = α ` (S0' - S)"
       by (auto simp add: inj_on_def subset_iff Ball_def)
      
      show ?case 
        using pre(2)[of σ x "α ` S"] prems S0'_props(3)  
        by (simp add: diff_alpha inv_x subs_alpha)
    next
      case prems: (4 σ S)

      from prems(1) have subs_alpha: "α ` S  α ` S0'" by auto

      from S0'_props prems
      have diff_alpha: "α ` S0' - α ` S = α ` (S0' - S)"
       by (auto simp add: inj_on_def subset_iff Ball_def)

      from prems(1,2) S0'_props(2,3)
      have alpha_eq: "α ` S  α ` S0'"
        apply (simp add: inj_on_def set_eq_iff image_iff Bex_def subset_iff)
        apply blast
      done

      show ?case
        using pre(4)[of "α ` S" σ] S0'_props prems
        by (auto simp add: subs_alpha diff_alpha alpha_eq)
    qed
  qed
end

lemma set_iterator_abs_genord_trivial:
  "set_iterator_abs_genord id (λ_. True) = set_iterator_genord"
by (simp add: set_iterator_genord_def set_iterator_abs_genord_def fun_eq_iff)

lemma set_iterator_abs_genord_trivial_simp [simp] :
  assumes "x. invar x"
      and "x. α x = x"
shows "set_iterator_abs_genord α invar = set_iterator_genord"
proof -
  from assms have "invar = (λ_. True)" and "α = id"
    by (simp_all add: fun_eq_iff)
  thus ?thesis by (simp add: set_iterator_abs_genord_trivial)
qed

subsection ‹Introduce iterators over representations›
lemma set_iterator_abs_genord_I2 :
  assumes it_OK: "set_iterator_genord iti S0 Rc"
      and R_OK: "xc1 xc2. invar xc1; invar xc2; Rc xc1 xc2  Ra (α xc1) (α xc2)"
      and dist: "xc1 xc2. invar xc1; invar xc2; xc1  S0; xc2  S0; α xc1 = α xc2  xc1 = xc2"
      and invar: "xc. xc  S0  invar xc"
      and S0'_eq: "S0' = α ` S0"
  shows "set_iterator_abs_genord α invar iti S0' Ra"
  proof -
    from it_OK obtain l0 where dist_l0: "distinct l0" and 
          S0_eq: "S0 = set l0" and 
          sort_Rc: "sorted_wrt Rc l0"  and iti_eq: "iti = foldli l0" 
      unfolding set_iterator_genord_def by auto

    have "set l0  S0" unfolding S0_eq by simp
    with dist_l0 sort_Rc 
    have map_props: "distinct (map α l0)  sorted_wrt Ra (map α l0)"
    proof (induct l0) 
      case Nil thus ?case by simp
    next
      case (Cons x l0)
      hence "distinct l0" and "x  set l0" and "x  S0" and "set l0  S0" and
            "distinct (map α l0)" "sorted_wrt Ra (map α l0)" "x'. x'  set l0  Rc x x'"
        by (simp_all)
      thus ?case using dist[of x] R_OK[of x] invar 
        apply (simp add: image_iff Ball_def subset_iff)
        apply metis
      done
    qed

    show ?thesis
      unfolding S0'_eq
      apply (rule set_iterator_abs_genord.intro)
      apply (rule_tac exI[where x = l0])
      apply (simp add: iti_eq map_props S0_eq Ball_def invar)
    done
  qed


subsection ‹Map-Iterators›

lemma map_to_set_cong: 
  "map_to_set m1 = map_to_set m2  m1 = m2"
apply (simp add: set_eq_iff map_to_set_def)
apply (simp add: fun_eq_iff)
apply (metis not_Some_eq)
done


definition "map_iterator_abs_genord α invar it m R  
set_iterator_abs_genord (λ(k,v). (k, α v)) (λ(k,v). invar v) it (map_to_set m) R"

lemma map_iterator_abs_genord_I2 :
  assumes it_OK: "map_iterator_genord iti m R'"
      and invar: "k v. m k = Some v  invar v"
      and R_OK: "k v k' v'. invar v  invar v'  R' (k, v) (k', v')  R (k, α v) (k', α v')"
      and m'_eq: "m' = ((map_option α) o m)"
  shows "map_iterator_abs_genord α invar iti m' R"
proof -
  let ?α' = "λ(k,v). (k, α v)"
  let ?invar' = "λ(k,v). invar v"

  have α_rewr: "?α' ` (map_to_set m) = map_to_set ((map_option α) o m)"
    by (auto simp add: map_to_set_def)
 
  note rule' = set_iterator_abs_genord_I2[OF it_OK[unfolded set_iterator_def], 
    of ?invar' R ?α' "map_to_set (map_option α  m)", unfolded α_rewr map_iterator_abs_genord_def[symmetric]]

  show ?thesis
    unfolding m'_eq
    apply (rule rule')
    apply (auto simp add: map_to_set_def invar R_OK)
  done
qed

lemma map_iterator_abs_genord_remove_abs2 :
  assumes iti: "map_iterator_abs_genord α invar iti m R"
  obtains m' where "map_iterator_genord iti m' (λ(k, v) (k', v'). R (k, α v) (k', α v'))"
       "(map_option α) o m' = m" "k v. m' k = Some v  invar v"
  proof -
    let ?α' = "λ(k,v). (k, α v)"
    let ?invar' = "λ(k,v). invar v"

    from set_iterator_abs_genord.foldli_transform [OF iti[unfolded map_iterator_abs_genord_def]]
    obtain lc where lc_invar: "k v. (k, v)  set lc  invar v" 
      and α_props: "distinct (map ?α' lc)" "map_to_set m = set (map ?α' lc)" 
                   "sorted_wrt R (map ?α' lc)" 
      and iti_eq: "iti = foldli lc" by blast

    from α_props(2)[symmetric] have in_lc: "k v. (k, v)  set lc  m k = Some (α v)" 
      by (auto simp add: set_eq_iff image_iff map_to_set_def Ball_def Bex_def)
    from α_props(1) have inj_on_α': "inj_on ?α' (set lc)" by (simp add: distinct_map)

    from in_lc inj_on_α'
    have inj_on_fst: "inj_on fst (set lc)"
      apply (simp add: inj_on_def Ball_def)
      apply (metis option.inject)
    done

    let ?m' = "map_of lc"

    from α_props have it': "map_iterator_genord iti ?m' (λx y. R (?α' x) (?α' y))"
      apply (rule_tac set_iterator_genord_I [of lc])  
      apply (simp_all add: distinct_map sorted_wrt_map iti_eq map_to_set_map_of inj_on_fst)
    done

    from inj_on_fst α_props(1)
    have "distinct (map fst (map ?α' lc))" 
      by (auto simp add: distinct_map inj_on_def Ball_def)
    hence "map_to_set m = map_to_set (map_of (map ?α' lc))"
      by (simp add: α_props map_to_set_map_of)
    hence m_eq: "map_option α  map_of lc = m"
      by (simp add: map_of_map[symmetric] map_to_set_cong)

    from that[of ?m'] it' lc_invar α_props(1) show ?thesis
      by (simp add: distinct_map split_def inj_on_fst ran_distinct m_eq)
  qed


lemma map_iterator_abs_genord_rule_P:
  assumes iti_OK: "map_iterator_abs_genord α invar iti m R"
      and I0: "I (dom m) σ0"
      and IP: "!!k v it σ.  c σ; k  it; invar v; m k = Some (α v); it  dom m; I it σ; 
                             k' v'. k'  it-{k}  invar v'  m k' = Some (α v')  R (k, α v) (k', α v');
                             k' v'. k'  it  invar v'  m k' = Some (α v')  R (k', α v') (k, α v)  
                            I (it - {k}) (f (k, v) σ)"
      and IF: "!!σ. I {} σ  P σ"
      and II: "!!σ it.  it  dom m; it  {}; ¬ c σ; I it σ;
                         k v k' v'. k  it  invar v  m k = Some (α v)  
                                     k'  it  invar v'  m k' = Some (α v')  
                                     R (k, α v) (k', α v')   P σ"
  shows "P (iti c f σ0)"
proof -
  let ?α' = "λ(k,v). (k, α v)"
  let ?invar' = "λ(k,v). invar v"

  from map_iterator_abs_genord_remove_abs2 [OF iti_OK]
  obtain m' where m'_props: "map_iterator_genord iti m' (λx y. R (?α' x) (?α' y))"
     "m = map_option α  m'" "k v. m' k = Some v  invar v" 
     by (auto simp add: split_def) 

  have dom_m'_eq: "dom m' = dom m"
    unfolding m'_props by (simp add: dom_def)

  show ?thesis
  proof (rule map_iterator_genord_rule_P[OF m'_props(1), of I], goal_cases)
    case 1
    thus ?case using I0 by (simp add: dom_m'_eq)   
  next
    case 3
    thus ?case using IF by simp   
  next
    case prems: (2 k v S σ)
    from IP [of σ k S v] prems
    show ?case
      by (simp add: m'_props) metis
  next
    case prems: (4 σ S)
    show ?case
      using II[of S σ] prems
      by (simp add: m'_props) metis
  qed
qed


lemma map_iterator_abs_genord_rule_insert_P:
  assumes iti_OK: "map_iterator_abs_genord α invar iti m R"
      and I0: "I {} σ0"
      and IP: "!!k v it σ.  c σ; k  dom m - it; invar v; m k = Some (α v); it  dom m; I it σ; 
                             k' v'. k'  (dom m - it)-{k}  invar v'  m k' = Some (α v')  R (k, α v) (k', α v');
                             k' v'. k'  it  invar v'  m k' = Some (α v')  R (k', α v') (k, α v)  
                            I (insert k it) (f (k, v) σ)"
      and IF: "!!σ. I (dom m) σ  P σ"
      and II: "!!σ it.  it  dom m; it  dom m; ¬ c σ; I it σ;
                         k v k' v'. k  it  invar v  m k = Some (α v)  
                                     k'  it  invar v'  m k' = Some (α v')  
                                     R (k, α v) (k', α v')   P σ"
  shows "P (iti c f σ0)"
proof -
  let ?α' = "λ(k,v). (k, α v)"
  let ?invar' = "λ(k,v). invar v"

  from map_iterator_abs_genord_remove_abs2 [OF iti_OK]
  obtain m' where m'_props: "map_iterator_genord iti m' (λx y. R (?α' x) (?α' y))"
     "m = map_option α  m'" "k v. m' k = Some v  invar v" 
     by (auto simp add: split_def) 

  have dom_m'_eq: "dom m' = dom m"
    unfolding m'_props by (simp add: dom_def)

  show ?thesis
  proof (rule map_iterator_genord_rule_insert_P[OF m'_props(1), of I], goal_cases)
    case 1
    thus ?case using I0 by simp   
  next
    case 3
    thus ?case using IF by (simp add: dom_m'_eq)   
  next
    case prems: (2 k v S σ)
    from IP [of σ k S v] prems
    show ?case 
      by (simp add: m'_props) metis
  next
    case prems: (4 σ S)
    show ?case
      using II[of S σ] prems
      by (simp add: m'_props) metis
  qed
qed


subsection ‹Unsorted Iterators›

definition "set_iterator_abs α invar it S0  set_iterator_abs_genord α invar it S0 (λ_ _. True)"

lemma set_iterator_abs_trivial:
  "set_iterator_abs id (λ_. True) = set_iterator"
by (simp add: set_iterator_def set_iterator_abs_def fun_eq_iff)

lemma set_iterator_abs_trivial_simp [simp]:
  assumes "x. invar x"
      and "x. α x = x"
shows "set_iterator_abs α invar = set_iterator"
proof -
  from assms have "invar = (λ_. True)" and "α = id"
    by (simp_all add: fun_eq_iff)
  thus ?thesis by (simp add: set_iterator_abs_trivial)
qed

lemma set_iterator_abs_I2 :
  assumes it_OK: "set_iterator iti S0"
      and dist: "xc1 xc2. invar xc1; invar xc2; xc1  S0; xc2  S0; α xc1 = α xc2  xc1 = xc2"
      and invar: "xc. xc  S0  invar xc"
      and S0'_OK: "S0' = α ` S0"
  shows "set_iterator_abs α invar iti S0'"
unfolding set_iterator_abs_def S0'_OK
apply (rule set_iterator_abs_genord_I2[OF it_OK[unfolded set_iterator_def], of invar _ α])
apply (simp_all add: dist invar)
done


lemma set_iterator_abs_simple_rule_P:
" set_iterator_abs α invar it S0;
   (xc. invar xc  f xc = f' (α xc));
   I S0 σ0;
   !!S σ x.  c σ; x  S; I S σ; S  S0   I (S - {x}) (f' x σ);
   !!σ. I {} σ  P σ;
   !!σ S. S  S0  S  {}  ¬ c σ  I S σ  P σ
   P (it c f σ0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_simple_rule_P [of α invar it S0 "λ_ _. True" f f' I σ0 c P]
by simp 

lemma set_iterator_abs_simple_no_cond_rule_P:
" set_iterator_abs α invar it S0;
   (xc. invar xc  f xc = f' (α xc));
   I S0 σ0;
   !!S σ x.  x  S; I S σ; S  S0   I (S - {x}) (f' x σ);
   !!σ. I {} σ  P σ
   P (it (λ_. True) f σ0)"
using set_iterator_abs_simple_rule_P[of α invar it S0 f f' I σ0 "λ_. True" P]
by simp 

lemma set_iterator_abs_simple_rule_insert_P :
" set_iterator_abs α invar it S0;
   (xc. invar xc  f xc = f' (α xc));
   I {} σ0;
   !!S σ x.  c σ; x  S0 - S; I S σ; S  S0    I (insert x S) (f' x σ);
   !!σ. I S0 σ  P σ;
   !!σ S. S  S0  S  S0  ¬ c σ  I S σ  P σ
   P (it c f σ0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_simple_rule_insert_P [of α invar it S0 "λ_ _. True" f f' I σ0 c P]
by simp 

lemma set_iterator_abs_no_cond_simple_rule_insert_P :
" set_iterator_abs α invar it S0;
   (xc. invar xc  f xc = f' (α xc));
   I {} σ0;
   !!S σ x.  x  S0 - S; I S σ; S  S0    I (insert x S) (f' x σ);
   !!σ. I S0 σ  P σ
   P (it (λ_. True) f σ0)"
using set_iterator_abs_simple_rule_insert_P[of α invar it S0 f f' I σ0 "λ_. True" P]
by simp 


lemma set_iterator_abs_rule_P:
" set_iterator_abs α invar it S0;
   I S0 σ0;
   !!S σ x.  c σ; invar x; α x  S; I S σ; S  S0   I (S - {α x}) (f x σ);
   !!σ. I {} σ  P σ;
   !!σ S. S  S0  S  {}  ¬ c σ  I S σ  P σ
   P (it c f σ0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_rule_P [of α invar it S0 "λ_ _. True" I σ0 c f P]
by simp 

lemma set_iterator_abs_no_cond_rule_P:
" set_iterator_abs α invar it S0;
   I S0 σ0;
   !!S σ x.  invar x; α x  S; I S σ; S  S0   I (S - {α x}) (f x σ);
   !!σ. I {} σ  P σ
   P (it (λ_. True) f σ0)"
using set_iterator_abs_rule_P[of α invar it S0 I σ0 "λ_. True" f P]
by simp 

lemma set_iterator_abs_rule_insert_P :
" set_iterator_abs α invar it S0;
   I {} σ0;
   !!S σ x.  c σ; invar x; α x  S0 - S; I S σ; S  S0    I (insert (α x) S) (f x σ);
   !!σ. I S0 σ  P σ;
   !!σ S. S  S0  S  S0  ¬ c σ  I S σ  P σ
   P (it c f σ0)"
unfolding set_iterator_abs_def
using set_iterator_abs_genord.iteratei_abs_rule_insert_P [of α invar it S0 "λ_ _. True" I σ0 c f P]
by simp 

lemma set_iterator_abs_no_cond_rule_insert_P :
" set_iterator_abs α invar it S0;
   I {} σ0;
   !!S σ x.  invar x; α x  S0 - S; I S σ; S  S0    I (insert (α x) S) (f x σ);
   !!σ. I S0 σ  P σ
   P (it (λ_. True) f σ0)"
using set_iterator_abs_rule_insert_P[of α invar it S0 I σ0 "λ_. True" f P]
by simp 


subsection ‹Unsorted Map-Iterators›

definition "map_iterator_abs α invar it m  map_iterator_abs_genord α invar it m (λ_ _. True)"

lemma map_iterator_abs_trivial:
  "map_iterator_abs id (λ_. True) = map_iterator"
by (simp add: set_iterator_def map_iterator_abs_def map_iterator_abs_genord_def 
              set_iterator_abs_genord_def set_iterator_genord_def fun_eq_iff)

lemma map_iterator_abs_trivial_simp [simp] :
  assumes "x. invar x"
      and "x. α x = x"
shows "map_iterator_abs α invar = map_iterator"
proof -
  from assms have "invar = (λ_. True)" and "α = id"
    by (simp_all add: fun_eq_iff)
  thus ?thesis by (simp add: map_iterator_abs_trivial)
qed


lemma map_iterator_abs_I2 :
  assumes it_OK: "map_iterator iti m"
      and invar: "k v. m k = Some v  invar v"
      and m'_eq: "m' = map_option α  m"
  shows "map_iterator_abs α invar iti m'"
using assms
unfolding map_iterator_abs_def set_iterator_def
by (rule_tac map_iterator_abs_genord_I2 [OF it_OK[unfolded set_iterator_def]]) simp_all

lemma map_iterator_abs_rule_P:
  assumes iti_OK: "map_iterator_abs α invar iti m"
      and I0: "I (dom m) σ0"
      and IP: "!!k v it σ.  c σ; k  it; invar v; m k = Some (α v); it  dom m; I it σ   
                            I (it - {k}) (f (k, v) σ)"
      and IF: "!!σ. I {} σ  P σ"
      and II: "!!σ it.  it  dom m; it  {}; ¬ c σ; I it σ   P σ"
  shows "P (iti c f σ0)"
apply (rule map_iterator_abs_genord_rule_P [OF iti_OK[unfolded map_iterator_abs_def], of I])
apply (simp_all add: I0 IP IF II)
done

lemma map_iterator_abs_no_cond_rule_P:
  assumes iti_OK: "map_iterator_abs α invar iti m"
      and I0: "I (dom m) σ0"
      and IP: "!!k v it σ.  k  it; invar v; m k = Some (α v); it  dom m; I it σ   
                            I (it - {k}) (f (k, v) σ)"
      and IF: "!!σ. I {} σ  P σ"
  shows "P (iti (λ_. True) f σ0)"
apply (rule map_iterator_abs_rule_P [OF iti_OK, of I])
apply (simp_all add: I0 IP IF)
done

lemma map_iterator_abs_rule_insert_P:
  assumes iti_OK: "map_iterator_abs α invar iti m"
      and I0: "I {} σ0"
      and IP: "!!k v it σ.  c σ; k  dom m - it; invar v; m k = Some (α v); it  dom m; I it σ   
                            I (insert k it) (f (k, v) σ)"
      and IF: "!!σ. I (dom m) σ  P σ"
      and II: "!!σ it.  it  dom m; it  dom m; ¬ c σ; I it σ   P σ"
  shows "P (iti c f σ0)"
apply (rule map_iterator_abs_genord_rule_insert_P [OF iti_OK[unfolded map_iterator_abs_def], of I])
apply (simp_all add: I0 IP IF II)
done

lemma map_iterator_abs_no_cond_rule_insert_P:
  assumes iti_OK: "map_iterator_abs α invar iti m"
      and I0: "I {} σ0"
      and IP: "!!k v it σ.  k  dom m - it; invar v; m k = Some (α v); it  dom m; I it σ   
                            I (insert k it) (f (k, v) σ)"
      and IF: "!!σ. I (dom m) σ  P σ"
  shows "P (iti (λ_. True) f σ0)"
apply (rule map_iterator_abs_genord_rule_insert_P [OF iti_OK[unfolded map_iterator_abs_def], of I])
apply (simp_all add: I0 IP IF)
done

end


Theory GenCF_Chapter

(*<*)
theory GenCF_Chapter imports Main begin 
(*>*)
text_raw ‹\isachapter{The Generic Collection Framework}›

text ‹
  The Generic Collection Framework is build on top of the 
  Automatic Refinement Framework. It contains set and map datastructures that
  are fully nestable, and a library of generic algorithms that are 
  automatically instantiated on demand.
›

(*<*)
end
(*>*)

Theory GenCF_Intf_Chapter

(*<*)
theory GenCF_Intf_Chapter imports Main begin 
(*>*)
text_raw ‹\isasection{Interfaces}›
(*<*)
end
(*>*)

Theory Intf_Map

section ‹\isaheader{Map Interface}›
theory Intf_Map
imports Refine_Monadic.Refine_Monadic
begin

consts i_map :: "interface  interface  interface"

definition [simp]: "op_map_empty  Map.empty"
definition op_map_lookup :: "'k  ('k'v)  'v"
  where [simp]: "op_map_lookup k m  m k"
definition [simp]: "op_map_update k v m  m(kv)"
definition [simp]: "op_map_delete k m  m |` (-{k})"
definition [simp]: "op_map_restrict P m  m |` {kdom m. P (k, the (m k))}"
definition [simp]: "op_map_isEmpty x  x=Map.empty"
definition [simp]: "op_map_isSng x  k v. x=[kv]"
definition [simp]: "op_map_ball m P  Ball (map_to_set m) P"
definition [simp]: "op_map_bex m P  Bex (map_to_set m) P"
definition [simp]: "op_map_size m  card (dom m)"
definition [simp]: "op_map_size_abort n m  min n (card (dom m))"
definition [simp]: "op_map_sel m P  SPEC (λ(k,v). m k = Some v  P k v)"
definition [simp]: "op_map_pick m  SPEC (λ(k,v). m k = Some v)"

definition [simp]: "op_map_pick_remove m  
  SPEC (λ((k,v),m'). m k = Some v  m' = m |` (-{k}))"


context begin interpretation autoref_syn .

lemma [autoref_op_pat]:
  "Map.empty  op_map_empty"
  "(m::'k'v) k  op_map_lookup$k$m"
  "m(kv)  op_map_update$k$v$m"
  "m |` (-{k})  op_map_delete$k$m"
  "m |` {kdom m. P (k, the (m k))}  op_map_restrict$P$m"

  "m=Map.empty  op_map_isEmpty$m"
  "Map.empty=m  op_map_isEmpty$m"
  "dom m = {}  op_map_isEmpty$m"
  "{} = dom m  op_map_isEmpty$m"

  "k v. m=[kv]  op_map_isSng$m"
  "k v. [kv]=m  op_map_isSng$m"
  "k. dom m={k}  op_map_isSng$m"
  "k. {k} = dom m  op_map_isSng$m"
  "1 = card (dom m)  op_map_isSng$m"

  "P. Ball (map_to_set m) P  op_map_ball$m$P"
  "P. Bex (map_to_set m) P  op_map_bex$m$P"

  "card (dom m)  op_map_size$m"

  "min n (card (dom m))  op_map_size_abort$n$m"
  "min (card (dom m)) n  op_map_size_abort$n$m"

  "P. SPEC (λ(k,v). m k=Some v  P k v)  op_map_sel$m$P"
  "P. SPEC (λ(k,v). P k v  m k=Some v)  op_map_sel$m$P"

  "P. SPEC (λ(k,v). m k = Some v)  op_map_pick$m"
  "P. SPEC (λ(k,v). (k,v)  map_to_set m)  op_map_pick$m"
  by (auto 
    intro!: eq_reflection ext
    simp: restrict_map_def dom_eq_singleton_conv card_Suc_eq map_to_set_def
    dest!: sym[of "Suc 0" "card (dom m)"] sym[of _ "dom m"]
  )

  lemma [autoref_op_pat]: 
    "SPEC (λ((k,v),m'). m k = Some v  m' = m |` (-{k})) 
       op_map_pick_remove$m"
    by simp

  lemma op_map_pick_remove_alt: "
    do {((k,v),m)  op_map_pick_remove m; f k v m}
      = (
    do {
      (k,v)SPEC (λ(k,v). m k = Some v); 
       let m=m |` (-{k});
       f k v m
    })"
    unfolding op_map_pick_remove_def
    apply (auto simp: pw_eq_iff refine_pw_simps)
    done

  lemma [autoref_op_pat]: 
    "do {
      (k,v)SPEC (λ(k,v). m k = Some v); 
       let m=m |` (-{k});
       f k v m
    }  do {((k,v),m)  op_map_pick_remove m; f k v m}"
    unfolding op_map_pick_remove_alt .


end

lemma [autoref_itype]:
  "op_map_empty ::i Ik,Ivii_map"
  "op_map_lookup ::i Ik i Ik,Ivii_map i Ivii_option"
  "op_map_update ::i Ik i Iv i Ik,Ivii_map i Ik,Ivii_map"
  "op_map_delete ::i Ik i Ik,Ivii_map i Ik,Ivii_map"
  "op_map_restrict 
    ::i (Ik,Ivii_prod i i_bool) i Ik,Ivii_map i Ik,Ivii_map"
  "op_map_isEmpty ::i Ik,Ivii_map i i_bool"
  "op_map_isSng ::i Ik,Ivii_map i i_bool"
  "op_map_ball ::i Ik,Ivii_map i (Ik,Ivii_prod i i_bool) i i_bool"
  "op_map_bex ::i Ik,Ivii_map i (Ik,Ivii_prod i i_bool) i i_bool"
  "op_map_size ::i Ik,Ivii_map i i_nat"
  "op_map_size_abort ::i i_nat i Ik,Ivii_map i i_nat"
  "(++) ::i Ik,Ivii_map i Ik,Ivii_map i Ik,Ivii_map"
  "map_of ::i Ik,Ivii_prodii_list i Ik,Ivii_map"

  "op_map_sel ::i Ik,Ivii_map i (Ik i Iv i i_bool) 
    i Ik,Ivii_prodii_nres"
  "op_map_pick ::i Ik,Ivii_map i Ik,Ivii_prodii_nres"
  "op_map_pick_remove 
    ::i Ik,Ivii_map i Ik,Ivii_prod,Ik,Ivii_mapii_prodii_nres"
  by simp_all

lemma hom_map1[autoref_hom]:
  "CONSTRAINT Map.empty (Rk,RvRm)"
  "CONSTRAINT map_of (Rk,Rvprod_rellist_rel  Rk,RvRm)"
  "CONSTRAINT (++) (Rk,RvRm  Rk,RvRm  Rk,RvRm)"
  by simp_all

term op_map_restrict
lemma hom_map2[autoref_hom]:
  "CONSTRAINT op_map_lookup (RkRk,RvRmRvoption_rel)"
  "CONSTRAINT op_map_update (RkRvRk,RvRmRk,RvRm)"
  "CONSTRAINT op_map_delete (RkRk,RvRmRk,RvRm)"
  "CONSTRAINT op_map_restrict ((Rk,Rvprod_rel  Id)  Rk,RvRm  Rk,RvRm)"
  "CONSTRAINT op_map_isEmpty (Rk,RvRmId)"
  "CONSTRAINT op_map_isSng (Rk,RvRmId)"
  "CONSTRAINT op_map_ball (Rk,RvRm(Rk,Rvprod_relId)Id)"
  "CONSTRAINT op_map_bex (Rk,RvRm(Rk,Rvprod_relId)Id)"
  "CONSTRAINT op_map_size (Rk,RvRmId)"
  "CONSTRAINT op_map_size_abort (IdRk,RvRmId)"

  "CONSTRAINT op_map_sel (Rk,RvRm(Rk  Rv  bool_rel)Rk×rRvnres_rel)"
  "CONSTRAINT op_map_pick (Rk,RvRm  Rk×rRvnres_rel)"
  "CONSTRAINT op_map_pick_remove (Rk,RvRm  (Rk×rRv)×rRk,RvRmnres_rel)"
  by simp_all


definition "finite_map_rel R  Range R  Collect (finite  dom)"
lemma finite_map_rel_trigger: "finite_map_rel R  finite_map_rel R" .


declaration Tagged_Solver.add_triggers 
  "Relators.relator_props_solver" @{thms finite_map_rel_trigger}

end

Theory Intf_Set

section ‹\isaheader{Set Interface}›
theory Intf_Set
imports Refine_Monadic.Refine_Monadic
begin
consts i_set :: "interface  interface"
lemmas [autoref_rel_intf] = REL_INTFI[of set_rel i_set]


definition [simp]: "op_set_delete x s  s - {x}"
definition [simp]: "op_set_isEmpty s  s = {}"
definition [simp]: "op_set_isSng s  card s = 1"
definition [simp]: "op_set_size_abort m s  min m (card s)"
definition [simp]: "op_set_disjoint a b  ab={}"
definition [simp]: "op_set_filter P s  {xs. P x}"
definition [simp]: "op_set_sel P s  SPEC (λx. xs  P x)"
definition [simp]: "op_set_pick s  SPEC (λx. xs)"
definition [simp]: "op_set_to_sorted_list ordR s 
   SPEC (λl. set l = s  distinct l  sorted_wrt ordR l)"
definition [simp]: "op_set_to_list s  SPEC (λl. set l = s  distinct l)"
definition [simp]: "op_set_cart x y  x × y"

(* TODO: Do op_set_pick_remove (like op_map_pick_remove) *)

context begin interpretation autoref_syn .
lemma [autoref_op_pat]:
  fixes s a b :: "'a set" and x::'a and P :: "'a  bool"
  shows
  "s - {x}  op_set_delete$x$s"

  "s = {}  op_set_isEmpty$s"
  "{}=s  op_set_isEmpty$s"

  "card s = 1  op_set_isSng$s"
  "x. s={x}  op_set_isSng$s"
  "x. {x}=s  op_set_isSng$s"

  "min m (card s)  op_set_size_abort$m$s"
  "min (card s) m  op_set_size_abort$m$s"

  "ab={}  op_set_disjoint$a$b"

  "{xs. P x}  op_set_filter$P$s"

  "SPEC (λx. xs  P x)  op_set_sel$P$s"
  "SPEC (λx. P x  xs)  op_set_sel$P$s"

  "SPEC (λx. xs)  op_set_pick$s"
  by (auto intro!: eq_reflection simp: card_Suc_eq)

lemma [autoref_op_pat]:
  "a × b  op_set_cart a b"
  by (auto intro!: eq_reflection simp: card_Suc_eq)

lemma [autoref_op_pat]:
  "SPEC (λ(u,v). (u,v)s)  op_set_pick$s"
  "SPEC (λ(u,v). P u v  (u,v)s)  op_set_sel$(case_prod P)$s"
  "SPEC (λ(u,v). (u,v)s  P u v)  op_set_sel$(case_prod P)$s"
  by (auto intro!: eq_reflection)

  lemma [autoref_op_pat]:
    "SPEC (λl. set l = s  distinct l  sorted_wrt ordR l) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. set l = s  sorted_wrt ordR l  distinct l) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. distinct l  set l = s  sorted_wrt ordR l) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. distinct l  sorted_wrt ordR l  set l = s) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. sorted_wrt ordR l  distinct l  set l = s) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. sorted_wrt ordR l  set l = s  distinct l) 
     OP (op_set_to_sorted_list ordR)$s"

    "SPEC (λl. s = set l  distinct l  sorted_wrt ordR l) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. s = set l  sorted_wrt ordR l  distinct l) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. distinct l  s = set l  sorted_wrt ordR l) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. distinct l  sorted_wrt ordR l  s = set l) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. sorted_wrt ordR l  distinct l  s = set l) 
     OP (op_set_to_sorted_list ordR)$s"
    "SPEC (λl. sorted_wrt ordR l  s = set l  distinct l) 
     OP (op_set_to_sorted_list ordR)$s"

    "SPEC (λl. set l = s  distinct l)  op_set_to_list$s"
    "SPEC (λl. distinct l  set l = s)  op_set_to_list$s"

    "SPEC (λl. s = set l  distinct l)  op_set_to_list$s"
    "SPEC (λl. distinct l  s = set l)  op_set_to_list$s"
    by (auto intro!: eq_reflection)

end

lemma [autoref_itype]:
  "{} ::i Iii_set"
  "insert ::i I i Iii_set i Iii_set"
  "op_set_delete ::i I i Iii_set i Iii_set"
  "(∈) ::i I i Iii_set i i_bool"
  "op_set_isEmpty ::i Iii_set i i_bool"
  "op_set_isSng ::i Iii_set i i_bool"
  "(∪) ::i Iii_set i Iii_set i Iii_set"
  "(∩) ::i Iii_set i Iii_set i Iii_set"
  "((-) :: 'a set  'a set  'a set) ::i Iii_set i Iii_set i Iii_set"
  "((=) :: 'a set  'a set  bool) ::i Iii_set i Iii_set i i_bool"
  "(⊆) ::i Iii_set i Iii_set i i_bool"
  "op_set_disjoint ::i Iii_set i Iii_set i i_bool"
  "Ball ::i Iii_set i (I i i_bool) i i_bool"
  "Bex ::i Iii_set i (I i i_bool) i i_bool"
  "op_set_filter ::i (I i i_bool) i Iii_set i Iii_set"
  "card ::i Iii_set i i_nat"
  "op_set_size_abort ::i i_nat i Iii_set i i_nat"
  "set ::i Iii_list i Iii_set"
  "op_set_sel ::i (I i i_bool) i Iii_set i Iii_nres"
  "op_set_pick ::i Iii_set i Iii_nres"
  "Sigma ::i Iaii_set i (Ia i Ibii_set) i Ia,Ibii_prodii_set"
  "(`) ::i (IaiIb) i Iaii_set i Ibii_set"
  "op_set_cart ::i IxiIsx i IyiIsy i Ix, Iyii_prodiIsp"
  "Union ::i Iii_setii_set i Iii_set"
  "atLeastLessThan ::i i_nat i i_nat i i_natii_set"
  by simp_all

lemma hom_set1[autoref_hom]:
  "CONSTRAINT {} (RRs)"
  "CONSTRAINT insert (RRRsRRs)"
  "CONSTRAINT (∈) (RRRsId)"
  "CONSTRAINT (∪) (RRsRRsRRs)"
  "CONSTRAINT (∩) (RRsRRsRRs)"
  "CONSTRAINT (-) (RRsRRsRRs)"
  "CONSTRAINT (=) (RRsRRsId)"
  "CONSTRAINT (⊆) (RRsRRsId)"
  "CONSTRAINT Ball (RRs(RId)Id)"
  "CONSTRAINT Bex (RRs(RId)Id)"
  "CONSTRAINT card (RRsId)"
  "CONSTRAINT set (RRlRRs)"
  "CONSTRAINT (`) ((RaRb)  RaRsRbRs)"
  "CONSTRAINT Union (RRiRo  RRi)"
  by simp_all

lemma hom_set2[autoref_hom]:
  "CONSTRAINT op_set_delete (RRRsRRs)"
  "CONSTRAINT op_set_isEmpty (RRsId)"
  "CONSTRAINT op_set_isSng (RRsId)"
  "CONSTRAINT op_set_size_abort (IdRRsId)"
  "CONSTRAINT op_set_disjoint (RRsRRsId)"
  "CONSTRAINT op_set_filter ((RId)RRsRRs)"
  "CONSTRAINT op_set_sel ((R  Id)RRsRRn)"
  "CONSTRAINT op_set_pick (RRsRRn)"
  by simp_all

lemma hom_set_Sigma[autoref_hom]:
  "CONSTRAINT Sigma (RaRs  (Ra  RbRs)  Ra,Rbprod_relRs2)"
  by simp_all
  
definition "finite_set_rel R  Range R  Collect (finite)"

lemma finite_set_rel_trigger: "finite_set_rel R  finite_set_rel R" .

declaration Tagged_Solver.add_triggers 
  "Relators.relator_props_solver" @{thms finite_set_rel_trigger}

end

Theory Intf_Hash

section ‹\isaheader{Hashable Interface}›
theory Intf_Hash
imports 
    Main
    "../../Lib/HashCode"
    "../../Lib/Code_Target_ICF"
    Automatic_Refinement.Automatic_Refinement
begin

type_synonym 'a eq = "'a  'a  bool"
type_synonym 'k bhc = "nat  'k  nat"

subsection ‹Abstract and concrete hash functions›

definition is_bounded_hashcode :: "('c×'a) set  'c eq  'c bhc  bool"
  where "is_bounded_hashcode R eq bhc  
             ((eq,(=))  R  R  bool_rel) 
             (n.  x  Domain R.  y  Domain R. eq x y  bhc n x = bhc n y) 
             (n x. 1 < n  bhc n x < n)"
definition abstract_bounded_hashcode :: "('c×'a) set  'c bhc  'a bhc"
  where "abstract_bounded_hashcode Rk bhc n x'  
             if x'  Range Rk 
                 then THE c. x. (x,x')  Rk  bhc n x = c
                 else 0"

lemma is_bounded_hashcodeI[intro]:
  "((eq,(=))  R  R  bool_rel) 
   (x y n. x  Domain R  y  Domain R  eq x y  bhc n x = bhc n y) 
   (x n. 1 < n  bhc n x < n)  is_bounded_hashcode R eq bhc"
  unfolding is_bounded_hashcode_def by force

lemma is_bounded_hashcodeD[dest]:
  assumes "is_bounded_hashcode R eq bhc"
  shows "(eq,(=))  R  R  bool_rel" and
        "n x y. x  Domain R  y  Domain R  eq x y  bhc n x = bhc n y" and
        "n x. 1 < n  bhc n x < n"
  using assms unfolding is_bounded_hashcode_def by simp_all

lemma bounded_hashcode_welldefined:
  assumes BHC: "is_bounded_hashcode Rk eq bhc" and
          R1: "(x1,x')  Rk" and R2: "(x2,x')  Rk"
  shows "bhc n x1 = bhc n x2"
proof-
  from is_bounded_hashcodeD[OF BHC] have "(eq,(=))  Rk  Rk  bool_rel" by simp
  with R1 R2 have "eq x1 x2" by (force dest: fun_relD)
  thus ?thesis using R1 R2 BHC by blast
qed

lemma abstract_bhc_correct[intro]:
  assumes "is_bounded_hashcode Rk eq bhc"
  shows "(bhc, abstract_bounded_hashcode Rk bhc)  
      nat_rel  Rk  nat_rel" (is "(bhc, ?bhc')  _")
proof (intro fun_relI)
  fix n n' x x'
  assume A: "(n,n')  nat_rel" and B: "(x,x')  Rk"
  hence C: "n = n'" and D: "x'  Range Rk" by auto
  have "?bhc' n' x' = bhc n x" 
      unfolding abstract_bounded_hashcode_def
      apply (simp add: C D, rule)
      apply (intro exI conjI, fact B, rule refl)
      apply (elim exE conjE, hypsubst,
          erule bounded_hashcode_welldefined[OF assms _ B])
      done
  thus "(bhc n x, ?bhc' n' x')  nat_rel" by simp
qed

lemma abstract_bhc_is_bhc[intro]:
  fixes Rk :: "('c×'a) set"
  assumes bhc: "is_bounded_hashcode Rk eq bhc"
  shows "is_bounded_hashcode Id (=) (abstract_bounded_hashcode Rk bhc)"
      (is "is_bounded_hashcode _ (=) ?bhc'")
proof
  fix x'::'a and y'::'a and n'::nat assume "x' = y'"
  thus "?bhc' n' x' = ?bhc' n' y'" by simp
next
  fix x'::'a and n'::nat assume "1 < n'"
  from abstract_bhc_correct[OF bhc] show "?bhc' n' x' < n'"
  proof (cases "x'  Range Rk")
    case False
      with 1 < n' show ?thesis 
          unfolding abstract_bounded_hashcode_def by simp
  next
    case True
      then obtain x where "(x,x')  Rk" ..
      have "(n',n')  nat_rel" ..
      from abstract_bhc_correct[OF assms] have "?bhc' n' x' = bhc n' x"
        apply -
        apply (drule fun_relD[OF _ (n',n')  nat_rel›],
               drule fun_relD[OF _ (x,x')  Rk], simp)
        done
      also from 1 < n' and bhc have "... < n'" by blast
      finally show "?bhc' n' x' < n'" .
  qed
qed simp

(*lemma hashable_bhc_is_bhc[autoref_ga_rules]:
  "⟦STRUCT_EQ_tag eq (=;) REL_IS_ID R⟧ ⟹ is_bounded_hashcode R eq bounded_hashcode"
  unfolding is_bounded_hashcode_def
  by (simp add: bounded_hashcode_bounds)*)

(* TODO: This is a hack that causes the relation to be instantiated to Id, if it is not
    yet fixed! *)
lemma hashable_bhc_is_bhc[autoref_ga_rules]:
  "STRUCT_EQ_tag eq (=); REL_FORCE_ID R  is_bounded_hashcode R eq bounded_hashcode_nat"
  unfolding is_bounded_hashcode_def
  by (simp add: bounded_hashcode_nat_bounds)


subsection ‹Default hash map size›

definition is_valid_def_hm_size :: "'k itself  nat  bool"
    where "is_valid_def_hm_size type n  n > 1"

lemma hashable_def_size_is_def_size[autoref_ga_rules]:
  shows "is_valid_def_hm_size TYPE('k::hashable) (def_hashmap_size TYPE('k))"
    unfolding is_valid_def_hm_size_def by (fact def_hashmap_size)

end

Theory Intf_Comp

section ‹\isaheader{Orderings By Comparison Operator}›
theory Intf_Comp
imports 
  Automatic_Refinement.Automatic_Refinement
begin

subsection ‹Basic Definitions›

datatype comp_res = LESS | EQUAL | GREATER

consts i_comp_res :: interface
abbreviation "comp_res_rel  Id :: (comp_res × _) set"
lemmas [autoref_rel_intf] = REL_INTFI[of comp_res_rel i_comp_res]

definition "comp2le cmp a b  
  case cmp a b of LESS  True | EQUAL  True | GREATER  False"

definition "comp2lt cmp a b  
  case cmp a b of LESS  True | EQUAL  False | GREATER  False"

definition "comp2eq cmp a b  
  case cmp a b of LESS  False | EQUAL  True | GREATER  False"

locale linorder_on =
  fixes D :: "'a set"
  fixes cmp :: "'a  'a  comp_res"
  assumes lt_eq: "xD; yD  cmp x y = LESS  (cmp y x = GREATER)"
  assumes refl[simp, intro!]: "xD  cmp x x = EQUAL"
  assumes trans[trans]: 
    " xD; yD; zD; cmp x y = LESS; cmp y z = LESS  cmp x z = LESS"
    " xD; yD; zD; cmp x y = LESS; cmp y z = EQUAL  cmp x z = LESS"
    " xD; yD; zD; cmp x y = EQUAL; cmp y z = LESS  cmp x z = LESS"
    " xD; yD; zD; cmp x y = EQUAL; cmp y z = EQUAL  cmp x z = EQUAL"
begin
  abbreviation "le  comp2le cmp"
  abbreviation "lt  comp2lt cmp"

  lemma eq_sym: "xD; yD  cmp x y = EQUAL  cmp y x = EQUAL"
    apply (cases "cmp y x")
    using lt_eq lt_eq[symmetric]
    by auto
end

abbreviation "linorder  linorder_on UNIV"

lemma linorder_to_class:
  assumes "linorder cmp" 
  assumes [simp]: "x y. cmp x y = EQUAL  x=y"
  shows "class.linorder (comp2le cmp) (comp2lt cmp)"
proof -
  interpret linorder_on UNIV cmp by fact
  show ?thesis
    apply (unfold_locales)
    unfolding comp2le_def comp2lt_def
    apply (auto split: comp_res.split comp_res.split_asm)
    using lt_eq apply simp
    using lt_eq apply simp
    using lt_eq[symmetric] apply simp
    apply (drule (1) trans[rotated 3], simp_all) []
    apply (drule (1) trans[rotated 3], simp_all) []
    apply (drule (1) trans[rotated 3], simp_all) []
    apply (drule (1) trans[rotated 3], simp_all) []
    using lt_eq apply simp
    using lt_eq apply simp
    using lt_eq[symmetric] apply simp
    done
qed

definition "dflt_cmp le lt a b  
  if lt a b then LESS 
  else if le a b then EQUAL 
  else GREATER"

lemma (in linorder) class_to_linorder:
  "linorder (dflt_cmp (≤) (<))"
  apply (unfold_locales)
  unfolding dflt_cmp_def
  by (auto split: if_split_asm)

lemma restrict_linorder: "linorder_on D cmp ; D'D  linorder_on D' cmp"
  apply (rule linorder_on.intro)
  apply (drule (1) rev_subsetD)+
  apply (erule (2) linorder_on.lt_eq)
  apply (drule (1) rev_subsetD)+
  apply (erule (1) linorder_on.refl)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  apply (drule (1) rev_subsetD)+
  apply (erule (5) linorder_on.trans)
  done

subsection ‹Operations on Linear Orderings›

text ‹Map with injective function›
definition cmp_img where "cmp_img f cmp a b  cmp (f a) (f b)"

lemma img_linorder[intro?]: 
  assumes LO: "linorder_on (f`D) cmp"
  shows "linorder_on D (cmp_img f cmp)"
  apply unfold_locales
  unfolding cmp_img_def
  apply (rule linorder_on.lt_eq[OF LO], auto) []
  apply (rule linorder_on.refl[OF LO], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  apply (erule (1) linorder_on.trans[OF LO, rotated -2], auto) []
  done

text ‹Combine›
definition "cmp_combine D1 cmp1 D2 cmp2 a b  
  if aD1  bD1 then cmp1 a b
  else if aD1  bD2 then LESS
  else if aD2  bD1 then GREATER
  else cmp2 a b
"

(* TODO: Move *)
lemma UnE': 
  assumes "xAB"
  obtains "xA" | "xA" "xB"
  using assms by blast

lemma combine_linorder[intro?]:
  assumes "linorder_on D1 cmp1"
  assumes "linorder_on D2 cmp2"
  assumes "D = D1D2"
  shows "linorder_on D (cmp_combine D1 cmp1 D2 cmp2)"
  apply unfold_locales
  unfolding cmp_combine_def
  using assms apply -
  apply (simp only:)
  apply (elim UnE)
  apply (auto dest: linorder_on.lt_eq) [4]

  apply (simp only:)
  apply (elim UnE)
  apply (auto dest: linorder_on.refl) [2]

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)

  apply (simp only:)
  apply (elim UnE')
  apply simp_all [8]
  apply (erule (5) linorder_on.trans)
  apply (erule (5) linorder_on.trans)
  done

subsection ‹Universal Linear Ordering›
text ‹With Zorn's Lemma, we get a universal linear (even wf) ordering›

definition "univ_order_rel  (SOME r. well_order_on UNIV r)"
definition "univ_cmp x y  
  if x=y then EQUAL 
  else if (x,y)univ_order_rel then LESS
  else GREATER"

lemma univ_wo: "well_order_on UNIV univ_order_rel"
  unfolding univ_order_rel_def
  using well_order_on[of UNIV]
  ..

lemma univ_linorder[intro?]: "linorder univ_cmp"
  apply unfold_locales
  unfolding univ_cmp_def 
  apply (auto split: if_split_asm)
  using univ_wo
  apply -
  unfolding well_order_on_def linear_order_on_def partial_order_on_def
    preorder_on_def
  apply (auto simp add: antisym_def) []
  apply (unfold total_on_def, fast) []
  apply (unfold trans_def, fast) []
  apply (auto simp add: antisym_def) []
  done

text ‹Extend any linear order to a universal order›
definition "cmp_extend D cmp  
  cmp_combine D cmp UNIV univ_cmp"

lemma extend_linorder[intro?]: 
  "linorder_on D cmp  linorder (cmp_extend D cmp)"
  unfolding cmp_extend_def
  apply rule
  apply assumption
  apply rule
  by simp

subsubsection ‹Lexicographic Order on Lists›  

fun cmp_lex where
  "cmp_lex cmp [] [] = EQUAL"
| "cmp_lex cmp [] _ = LESS"
| "cmp_lex cmp _ [] = GREATER"
| "cmp_lex cmp (a#l) (b#m) = (
    case cmp a b of
      LESS  LESS
    | EQUAL  cmp_lex cmp l m
    | GREATER  GREATER)"

primrec cmp_lex' where
  "cmp_lex' cmp [] m = (case m of []  EQUAL | _  LESS)"
| "cmp_lex' cmp (a#l) m = (case m of []  GREATER | (b#m)  
    (case cmp a b of
      LESS  LESS
    | EQUAL  cmp_lex' cmp l m
    | GREATER  GREATER
  ))"

lemma cmp_lex_alt: "cmp_lex cmp l m = cmp_lex' cmp l m"
  apply (induct l arbitrary: m)
  apply (auto split: comp_res.split list.split)
  done

lemma (in linorder_on) lex_linorder[intro?]:
  "linorder_on (lists D) (cmp_lex cmp)"
proof
  fix l m
  assume "llists D" "mlists D"
  thus "(cmp_lex cmp l m = LESS) = (cmp_lex cmp m l = GREATER)"
    apply (induct cmpcmp l m rule: cmp_lex.induct)
    apply (auto split: comp_res.split simp: lt_eq)
    apply (auto simp: lt_eq[symmetric])
    done
next
  fix x
  assume "xlists D"
  thus "cmp_lex cmp x x = EQUAL"
    by (induct x) auto
next
  fix x y z
  assume M: "xlists D" "ylists D" "zlists D"

  {
    assume "cmp_lex cmp x y = LESS" "cmp_lex cmp y z = LESS"
    thus "cmp_lex cmp x z = LESS"
      using M
      apply (induct cmpcmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z, auto) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      done
  }

  {
    assume "cmp_lex cmp x y = LESS" "cmp_lex cmp y z = EQUAL"
    thus "cmp_lex cmp x z = LESS"
      using M
      apply (induct cmpcmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z, auto) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      done
  }

  {
    assume "cmp_lex cmp x y = EQUAL" "cmp_lex cmp y z = LESS"
    thus "cmp_lex cmp x z = LESS"
      using M
      apply (induct cmpcmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z,
        auto split: comp_res.split_asm comp_res.split,
        (drule (4) trans, simp)+
      ) []
      done
  }

  {
    assume "cmp_lex cmp x y = EQUAL" "cmp_lex cmp y z = EQUAL"
    thus "cmp_lex cmp x z = EQUAL"
      using M
      apply (induct cmpcmp x y arbitrary: z rule: cmp_lex.induct)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (case_tac z)
      apply (auto split: comp_res.split_asm comp_res.split)
      apply (drule (4) trans, simp)+
      done
  }
qed

subsubsection ‹Lexicographic Order on Pairs›  

fun cmp_prod where 
  "cmp_prod cmp1 cmp2 (a1,a2) (b1,b2) 
  = (
    case cmp1 a1 b1 of
      LESS  LESS
    | EQUAL  cmp2 a2 b2
    | GREATER  GREATER)"

lemma cmp_prod_alt: "cmp_prod = (λcmp1 cmp2 (a1,a2) (b1,b2). (
    case cmp1 a1 b1 of
      LESS  LESS
    | EQUAL  cmp2 a2 b2
    | GREATER  GREATER))"
  by (auto intro!: ext)

lemma prod_linorder[intro?]: 
  assumes A: "linorder_on A cmp1" 
  assumes B: "linorder_on B cmp2" 
  shows "linorder_on (A×B) (cmp_prod cmp1 cmp2)"
proof -
  interpret A: linorder_on A cmp1
    + B: linorder_on B cmp2 by fact+

  show ?thesis
    apply unfold_locales
    apply (auto split: comp_res.split comp_res.split_asm,
      simp_all add: A.lt_eq B.lt_eq,
      simp_all add: A.lt_eq[symmetric]
      ) []

    apply (auto split: comp_res.split comp_res.split_asm) []

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+

    apply (auto split: comp_res.split comp_res.split_asm) []
    apply (drule (4) A.trans B.trans, simp)+
    done
qed

subsection ‹Universal Ordering for Sets that is Effective for Finite Sets›

subsubsection ‹Sorted Lists of Sets›
text ‹Some more results about sorted lists of finite sets›

lemma set_to_map_set_is_map_of: 
  "distinct (map fst l)  set_to_map (set l) = map_of l"
  apply (induct l)
  apply (auto simp: set_to_map_insert)
  done

context linorder begin

  lemma sorted_list_of_set_eq_nil[simp]:
    assumes "finite A" 
    shows "sorted_list_of_set A = []  A={}"
    using assms
    apply (induct rule: finite_induct)
    apply simp
    apply simp
    done

  lemma sorted_list_of_set_eq_nil2[simp]:
    assumes "finite A" 
    shows "[] = sorted_list_of_set A  A={}"
    using assms
    by (auto dest: sym)

  lemma set_insort[simp]: "set (insort x l) = insert x (set l)"
    by (induct l) auto

  lemma sorted_list_of_set_inj_aux:
    fixes A B :: "'a set"
    assumes "finite A" 
    assumes "finite B" 
    assumes "sorted_list_of_set A = sorted_list_of_set B"
    shows "A=B"
    using assms
  proof -
    from ‹finite B have "B = set (sorted_list_of_set B)" by simp
    also from assms have " = set (sorted_list_of_set (A))"
      by simp
    also from ‹finite A 
    have "set (sorted_list_of_set (A)) = A"
      by simp
    finally show ?thesis by simp
  qed

  lemma sorted_list_of_set_inj: "inj_on sorted_list_of_set (Collect finite)"
    apply (rule inj_onI)
    using sorted_list_of_set_inj_aux
    by blast
 
  lemma the_sorted_list_of_set:
    assumes "distinct l"
    assumes "sorted l"
    shows "sorted_list_of_set (set l) = l"
    using assms
    by (simp 
      add: sorted_list_of_set_sort_remdups distinct_remdups_id sorted_sort_id)


  definition "sorted_list_of_map m  
    map (λk. (k, the (m k))) (sorted_list_of_set (dom m))"

  lemma the_sorted_list_of_map:
    assumes "distinct (map fst l)"
    assumes "sorted (map fst l)"
    shows "sorted_list_of_map (map_of l) = l"
  proof -
    have "dom (map_of l) = set (map fst l)" by (induct l) force+
    hence "sorted_list_of_set (dom (map_of l)) = map fst l"
      using the_sorted_list_of_set[OF assms] by simp
    hence "sorted_list_of_map (map_of l) 
      = map (λk. (k, the (map_of l k))) (map fst l)"
      unfolding sorted_list_of_map_def by simp
    also have " = l" using ‹distinct (map fst l)
    proof (induct l)
      case Nil thus ?case by simp
    next
      case (Cons a l) 
      hence 
        1: "distinct (map fst l)" 
        and 2: "fst afst`set l" 
        and 3: "map (λk. (k, the (map_of l k))) (map fst l) = l" 
        by simp_all

      from 2 have [simp]: "¬(xset l. fst x = fst a)"
        by (auto simp: image_iff)

      show ?case
        apply simp
        apply (subst (3) 3[symmetric])
        apply simp
        done
    qed
    finally show ?thesis .
  qed

  lemma map_of_sorted_list_of_map[simp]:
    assumes FIN: "finite (dom m)" 
    shows "map_of (sorted_list_of_map m) = m"
    unfolding sorted_list_of_map_def
  proof -
    have "set (sorted_list_of_set (dom m)) = dom m"
      and DIST: "distinct (sorted_list_of_set (dom m))"
      by (simp_all add: FIN) 

    have [simp]: "(fst  (λk. (k, the (m k)))) = id" by auto

    have [simp]: "(λk. (k, the (m k))) ` dom m = map_to_set m"
      by (auto simp: map_to_set_def)

    show "map_of (map (λk. (k, the (m k))) (sorted_list_of_set (dom m))) = m"
      apply (subst set_to_map_set_is_map_of[symmetric])
      apply (simp add: DIST)
      apply (subst set_map)
      apply (simp add: FIN map_to_set_inverse)
      done
  qed

  lemma sorted_list_of_map_inj_aux:
    fixes A B :: "'a'b"
    assumes [simp]: "finite (dom A)" 
    assumes [simp]: "finite (dom B)" 
    assumes E: "sorted_list_of_map A = sorted_list_of_map B"
    shows "A=B"
    using assms
  proof -
    have "A = map_of (sorted_list_of_map A)" by simp
    also note E
    also have "map_of (sorted_list_of_map B) = B" by simp
    finally show ?thesis .
  qed

  lemma sorted_list_of_map_inj: 
    "inj_on sorted_list_of_map (Collect (finite o dom))"
    apply (rule inj_onI)
    using sorted_list_of_map_inj_aux
    by auto
end

definition "cmp_set cmp  
  cmp_extend (Collect finite) (
    cmp_img
      (linorder.sorted_list_of_set (comp2le cmp)) 
      (cmp_lex cmp)
  )"

thm img_linorder

lemma set_ord_linear[intro?]: 
  "linorder cmp  linorder (cmp_set cmp)"
  unfolding cmp_set_def
  apply rule
  apply rule
  apply (rule restrict_linorder)
  apply (erule linorder_on.lex_linorder)
  apply simp
  done

definition "cmp_map cmpk cmpv 
  cmp_extend (Collect (finite o dom)) (
    cmp_img
      (linorder.sorted_list_of_map (comp2le cmpk))
      (cmp_lex (cmp_prod cmpk cmpv))
  )
"

lemma map_to_set_inj[intro!]: "inj map_to_set"
  apply (rule inj_onI)
  unfolding map_to_set_def
  apply (rule ext)
  apply (case_tac "x xa")
  apply (case_tac [!] "y xa")
  apply force+
  done

corollary map_to_set_inj'[intro!]: "inj_on map_to_set S"
  by (metis map_to_set_inj subset_UNIV subset_inj_on)
  
lemma map_ord_linear[intro?]: 
  assumes A: "linorder cmpk" 
  assumes B: "linorder cmpv" 
  shows "linorder (cmp_map cmpk cmpv)"
proof -
  interpret lk: linorder_on UNIV cmpk by fact
  interpret lv: linorder_on UNIV cmpv by fact
  
  show ?thesis
    unfolding cmp_map_def
    apply rule
    apply rule
    apply (rule restrict_linorder)
    apply (rule linorder_on.lex_linorder)
    apply (rule)
    apply fact
    apply fact
    apply simp
    done
qed
  
  
locale eq_linorder_on = linorder_on +
  assumes cmp_imp_equal: "xD; yD  cmp x y = EQUAL  x = y"
begin
  lemma cmp_eq[simp]: "xD; yD  cmp x y = EQUAL  x = y"
    by (auto simp: cmp_imp_equal)
end
  
abbreviation "eq_linorder  eq_linorder_on UNIV"

lemma dflt_cmp_2inv[simp]: 
  "dflt_cmp (comp2le cmp) (comp2lt cmp) = cmp"
  unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
  apply (auto split: comp_res.splits intro!: ext)
  done

lemma (in linorder) dflt_cmp_inv2[simp]:
  shows 
  "(comp2le (dflt_cmp (≤) (<)))= (≤)"
  "(comp2lt (dflt_cmp (≤) (<)))= (<)"
proof -
  show "(comp2lt (dflt_cmp (≤) (<)))= (<)"
    unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
    apply (auto split: comp_res.splits intro!: ext)
    done

  show "(comp2le (dflt_cmp (≤) (<))) = (≤)"
    unfolding dflt_cmp_def[abs_def] comp2le_def[abs_def] comp2lt_def[abs_def]
    apply (auto split: comp_res.splits intro!: ext)
    done

qed
    
lemma eq_linorder_class_conv:
  "eq_linorder cmp  class.linorder (comp2le cmp) (comp2lt cmp)"
proof
  assume "eq_linorder cmp"
  then interpret eq_linorder_on UNIV cmp .
  have "linorder cmp" by unfold_locales
  show "class.linorder (comp2le cmp) (comp2lt cmp)"
    apply (rule linorder_to_class)
    apply fact
    by simp
next
  assume "class.linorder (comp2le cmp) (comp2lt cmp)"
  then interpret linorder "comp2le cmp" "comp2lt cmp" .
  
  from class_to_linorder interpret linorder_on UNIV cmp
    by simp
  show "eq_linorder cmp"
  proof
    fix x y
    assume "cmp x y = EQUAL"
    hence "comp2le cmp x y" "¬comp2lt cmp x y"
      by (auto simp: comp2le_def comp2lt_def)
    thus "x=y" by simp
  qed
qed
  
lemma (in linorder) class_to_eq_linorder:
  "eq_linorder (dflt_cmp (≤) (<))"
proof -
  interpret linorder_on UNIV "dflt_cmp (≤) (<)"
    by (rule class_to_linorder)

  show ?thesis
    apply unfold_locales
    apply (auto simp: dflt_cmp_def split: if_split_asm)
    done
qed

lemma eq_linorder_comp2eq_eq: 
  assumes "eq_linorder cmp"
  shows "comp2eq cmp = (=)"
proof -
  interpret eq_linorder_on UNIV cmp by fact
  show ?thesis
    apply (intro ext)
    unfolding comp2eq_def
    apply (auto split: comp_res.split dest: refl)
    done
qed
    
lemma restrict_eq_linorder: 
  assumes "eq_linorder_on D cmp" 
  assumes S: "D'D" 
  shows "eq_linorder_on D' cmp"
proof -
  interpret eq_linorder_on D cmp by fact
  
  show ?thesis
    apply (rule eq_linorder_on.intro)
    apply (rule restrict_linorder[where D=D])
    apply unfold_locales []
    apply fact
    apply unfold_locales
    using S
    apply -
    apply (drule (1) rev_subsetD)+
    apply auto
    done
qed
  
lemma combine_eq_linorder[intro?]:
  assumes A: "eq_linorder_on D1 cmp1"
  assumes B: "eq_linorder_on D2 cmp2"
  assumes EQ: "D=D1D2"
  shows "eq_linorder_on D (cmp_combine D1 cmp1 D2 cmp2)"
proof -
  interpret A: eq_linorder_on D1 cmp1 by fact
  interpret B: eq_linorder_on D2 cmp2 by fact
  interpret linorder_on "(D1  D2)" "(cmp_combine D1 cmp1 D2 cmp2)"
    apply rule
    apply unfold_locales
    by simp
  
  show ?thesis
    apply (simp only: EQ)
    apply unfold_locales
    unfolding cmp_combine_def
    by (auto split: if_split_asm)
qed

lemma img_eq_linorder[intro?]:
  assumes A: "eq_linorder_on (f`D) cmp"
  assumes INJ: "inj_on f D"
  shows "eq_linorder_on D (cmp_img f cmp)"
proof -
  interpret eq_linorder_on "f`D" cmp by fact
  interpret L: linorder_on "(D)" "(cmp_img f cmp)"
    apply rule
    apply unfold_locales
    done
  
  show ?thesis
    apply unfold_locales
    unfolding cmp_img_def
    using INJ
    apply (auto dest: inj_onD)
    done
qed

lemma univ_eq_linorder[intro?]:
  shows "eq_linorder univ_cmp"
  apply (rule eq_linorder_on.intro)
  apply rule
  apply unfold_locales
  unfolding univ_cmp_def
  apply (auto split: if_split_asm)
  done
  
lemma extend_eq_linorder[intro?]:
  assumes "eq_linorder_on D cmp"
  shows "eq_linorder (cmp_extend D cmp)"
proof -
  interpret eq_linorder_on D cmp by fact
  show ?thesis
    unfolding cmp_extend_def
    apply (rule)
    apply fact
    apply rule
    by simp
qed
  
lemma lex_eq_linorder[intro?]:
  assumes "eq_linorder_on D cmp"
  shows "eq_linorder_on (lists D) (cmp_lex cmp)"
proof -
  interpret eq_linorder_on D cmp by fact
  show ?thesis
    apply (rule eq_linorder_on.intro)
    apply rule
    apply unfold_locales
    subgoal for l m
      apply (induct cmpcmp l m rule: cmp_lex.induct)
      apply (auto split: comp_res.splits)
      done
    done
qed

lemma prod_eq_linorder[intro?]:
  assumes "eq_linorder_on D1 cmp1"
  assumes "eq_linorder_on D2 cmp2"
  shows "eq_linorder_on (D1×D2) (cmp_prod cmp1 cmp2)"
proof -
  interpret A: eq_linorder_on D1 cmp1 by fact
  interpret B: eq_linorder_on D2 cmp2 by fact
  show ?thesis
    apply (rule eq_linorder_on.intro)
    apply rule
    apply unfold_locales
    apply (auto split: comp_res.splits)
    done
qed

lemma set_ord_eq_linorder[intro?]: 
  "eq_linorder cmp  eq_linorder (cmp_set cmp)"
  unfolding cmp_set_def
  apply rule
  apply rule
  apply (rule restrict_eq_linorder)
  apply rule
  apply assumption
  apply simp

  apply (rule linorder.sorted_list_of_set_inj)
  apply (subst (asm) eq_linorder_class_conv)
  .

lemma map_ord_eq_linorder[intro?]: 
  "eq_linorder cmpk; eq_linorder cmpv  eq_linorder (cmp_map cmpk cmpv)"
  unfolding cmp_map_def
  apply rule
  apply rule
  apply (rule restrict_eq_linorder)
  apply rule
  apply rule
  apply assumption
  apply assumption
  apply simp

  apply (rule linorder.sorted_list_of_map_inj)
  apply (subst (asm) eq_linorder_class_conv)
  .

definition cmp_unit :: "unit  unit  comp_res" 
  where [simp]: "cmp_unit u v  EQUAL"

lemma cmp_unit_eq_linorder:
  "eq_linorder cmp_unit"
  by unfold_locales simp_all
  
subsection ‹Parametricity›  
  
lemma param_cmp_extend[param]:
  assumes "(cmp,cmp')R  R  Id"
  assumes "Range R  D"
  shows "(cmp,cmp_extend D cmp')  R  R  Id"
  unfolding cmp_extend_def cmp_combine_def[abs_def]
  using assms
  apply clarsimp
  by (blast dest!: fun_relD)

lemma param_cmp_img[param]: 
  "(cmp_img,cmp_img)  (RaRb)  (RbRbRc)  Ra  Ra  Rc"
  unfolding cmp_img_def[abs_def]
  by parametricity

lemma param_comp_res[param]:
  "(LESS,LESS)Id"
  "(EQUAL,EQUAL)Id"
  "(GREATER,GREATER)Id"
  "(case_comp_res,case_comp_res)RaRaRaIdRa"
  by (auto split: comp_res.split)

term cmp_lex
lemma param_cmp_lex[param]:
  "(cmp_lex,cmp_lex)(RaRbId)Ralist_relRblist_relId"
  unfolding cmp_lex_alt[abs_def] cmp_lex'_def
  by (parametricity)

term cmp_prod
lemma param_cmp_prod[param]:
  "(cmp_prod,cmp_prod)
  (RaRbId)(RcRdId)Ra,Rcprod_relRb,Rdprod_relId"
  unfolding cmp_prod_alt
  by (parametricity)

lemma param_cmp_unit[param]: 
  "(cmp_unit,cmp_unit)IdIdId" 
  by auto

lemma param_comp2eq[param]: "(comp2eq,comp2eq)(RRId)RRId"
  unfolding comp2eq_def[abs_def]
  by (parametricity)


  
lemma cmp_combine_paramD:
  assumes "(cmp,cmp_combine D1 cmp1 D2 cmp2)RRId"
  assumes "Range R  D1"
  shows "(cmp,cmp1)RRId"
  using assms
  unfolding cmp_combine_def[abs_def]
  apply (intro fun_relI)
  apply (drule_tac x=a in fun_relD, assumption)
  apply (drule_tac x=aa in fun_relD, assumption)
  apply (drule RangeI, drule (1) rev_subsetD)
  apply (drule RangeI, drule (1) rev_subsetD)
  apply simp
  done

lemma cmp_extend_paramD:
  assumes "(cmp,cmp_extend D cmp')RRId"
  assumes "Range R  D"
  shows "(cmp,cmp')RRId"
  using assms
  unfolding cmp_extend_def
  apply (rule cmp_combine_paramD)
  done
  

subsection ‹Tuning of Generated Implementation›
lemma [autoref_post_simps]: "comp2eq (dflt_cmp (≤) ((<)::_::linorder_)) = (=)"
  by (simp add: class_to_eq_linorder eq_linorder_comp2eq_eq)



end

Theory GenCF_Gen_Chapter

(*<*)
theory GenCF_Gen_Chapter imports Main begin 
(*>*)
text_raw ‹\isasection{Generic Algorithms}›
(*<*)
end
(*>*)

Theory Gen_Set

section ‹\isaheader{Generic Set Algorithms}›
theory Gen_Set
imports "../Intf/Intf_Set" "../../Iterator/Iterator"
begin

  lemma foldli_union: "det_fold_set X (λ_. True) insert a ((∪) a)"
  proof (rule, goal_cases)
    case (1 l) thus ?case
      by (induct l arbitrary: a) auto
  qed

  definition gen_union
    :: "_  ('k  's2  's2) 
         's1  's2  's2"
    where 
    "gen_union it ins A B  it A (λ_. True) ins B"

  lemma gen_union[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes INS: "GEN_OP ins Set.insert (RkRkRs2RkRs2)"
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
    shows "(gen_union (λx. foldli (tsl x)) ins,(∪)) 
     (RkRs1)  (RkRs2)  (RkRs2)"
    apply (intro fun_relI)
    apply (subst Un_commute)
    unfolding gen_union_def 
    apply (rule det_fold_set[OF 
      foldli_union IT[unfolded autoref_tag_defs]])
    using INS
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_inter: "det_fold_set X (λ_. True) 
    (λx s. if xa then insert x s else s) {} (λs. sa)" 
    (is "det_fold_set _ _ ?f _ _")
  proof -
    {
      fix l s0
      have "foldli l (λ_. True) 
        (λx s. if xa then insert x s else s) s0 = s0  (set l  a)"
        by (induct l arbitrary: s0) auto
    }
    from this[of _ "{}"] show ?thesis apply - by rule simp
  qed

  definition gen_inter :: "_  
    ('k  's2  bool)  _"
    where "gen_inter it1 memb2 ins3 empty3 s1 s2 
     it1 s1 (λ_. True) 
      (λx s. if memb2 x s2 then ins3 x s else s) empty3"

  lemma gen_inter[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
    assumes MEMB:
      "GEN_OP memb2 (∈) (Rk  RkRs2  Id)"
    assumes INS: 
      "GEN_OP ins3 Set.insert (RkRkRs3RkRs3)"
    assumes EMPTY: 
      "GEN_OP empty3 {} (RkRs3)"
    shows "(gen_inter (λx. foldli (tsl x)) memb2 ins3 empty3,(∩)) 
     (RkRs1)  (RkRs2)  (RkRs3)"
    apply (intro fun_relI)
    unfolding gen_inter_def
    apply (rule det_fold_set[OF foldli_inter IT[unfolded autoref_tag_defs]])
    using MEMB INS EMPTY
    unfolding autoref_tag_defs
    apply (parametricity)+
    done
 
  lemma foldli_diff: 
    "det_fold_set X (λ_. True) (λx s. op_set_delete x s) s ((-) s)"
  proof (rule, goal_cases)
    case (1 l) thus ?case
      by (induct l arbitrary: s) auto
  qed

  definition gen_diff :: "('k's1's1)  _  's2  _ "
    where "gen_diff del1 it2 s1 s2 
     it2 s2 (λ_. True) (λx s. del1 x s) s1"

  lemma gen_diff[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes DEL:
      "GEN_OP del1 op_set_delete (Rk  RkRs1  RkRs1)"
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs2 it2)"
    shows "(gen_diff del1 (λx. foldli (it2 x)),(-)) 
       (RkRs1)  (RkRs2)  (RkRs1)"
    apply (intro fun_relI)
    unfolding gen_diff_def 
    apply (rule det_fold_set[OF foldli_diff IT[unfolded autoref_tag_defs]])
    using DEL
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_ball_aux: 
    "foldli l (λx. x) (λx _. P x) b  b  Ball (set l) P"
    by (induct l arbitrary: b) auto

  lemma foldli_ball: "det_fold_set X (λx. x) (λx _. P x) True (λs. Ball s P)"
    apply rule using foldli_ball_aux[where b=True] by simp

  definition gen_ball :: "_  's  ('k  bool)  _ "
    where "gen_ball it s P  it s (λx. x) (λx _. P x) True"

  lemma gen_ball[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_ball (λx. foldli (it x)),Ball)  RkRs  (RkId)  Id"
    apply (intro fun_relI)
    unfolding gen_ball_def
    apply (rule det_fold_set[OF foldli_ball IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma foldli_bex_aux: "foldli l (λx. ¬x) (λx _. P x) b  b  Bex (set l) P"
    by (induct l arbitrary: b) auto

  lemma foldli_bex: "det_fold_set X (λx. ¬x) (λx _. P x) False (λs. Bex s P)"
    apply rule using foldli_bex_aux[where b=False] by simp

  definition gen_bex :: "_  's  ('k  bool)  _ "
    where "gen_bex it s P  it s (λx. ¬x) (λx _. P x) False"

  lemma gen_bex[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_bex (λx. foldli (it x)),Bex)  RkRs  (RkId)  Id"
    apply (intro fun_relI)
    unfolding gen_bex_def 
    apply (rule det_fold_set[OF foldli_bex IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma ball_subseteq:
    "(Ball s1 (λx. xs2))  s1  s2"
    by blast

  definition gen_subseteq 
    :: "('s1  ('k  bool)  bool)  ('k  's2  bool)  _" 
    where "gen_subseteq ball1 mem2 s1 s2  ball1 s1 (λx. mem2 x s2)"

  lemma gen_subseteq[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ball1 Ball (RkRs1  (RkId)  Id)"
    assumes "GEN_OP mem2 (∈) (Rk  RkRs2  Id)"
    shows "(gen_subseteq ball1 mem2,(⊆))  RkRs1  RkRs2  Id"
    apply (intro fun_relI)
    unfolding gen_subseteq_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_subseteq[symmetric])
    apply parametricity
    done

  definition "gen_equal ss1 ss2 s1 s2  ss1 s1 s2  ss2 s2 s1"

  lemma gen_equal[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ss1 (⊆) (RkRs1  RkRs2  Id)"
    assumes "GEN_OP ss2 (⊆) (RkRs2  RkRs1  Id)"
    shows "(gen_equal ss1 ss2, (=))  RkRs1  RkRs2  Id"
    apply (intro fun_relI)
    unfolding gen_equal_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst set_eq_subset)
    apply (parametricity)
    done

  lemma foldli_card_aux: "distinct l  foldli l (λ_. True) 
    (λ_ n. Suc n) n = n + card (set l)"
    apply (induct l arbitrary: n) 
    apply auto
    done
  
  lemma foldli_card: "det_fold_set X (λ_. True) (λ_ n. Suc n) 0 card"
    apply rule using foldli_card_aux[where n=0] by simp

  definition gen_card where
    "gen_card it s  it s (λx. True) (λ_ n. Suc n) 0"

  lemma gen_card[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_card (λx. foldli (it x)),card)  RkRs  Id"
    apply (intro fun_relI)
    unfolding gen_card_def
    apply (rule det_fold_set[OF foldli_card IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma fold_set: "fold Set.insert l s = s  set l"
    by (induct l arbitrary: s) auto

  definition gen_set :: "'s  ('k  's  's)  _" where
    "gen_set emp ins l = fold ins l emp"

  lemma gen_set[autoref_rules_raw]: 
    assumes PRIO_TAG_GEN_ALGO
    assumes EMPTY: 
      "GEN_OP emp {} (RkRs)"
    assumes INS: 
      "GEN_OP ins Set.insert (RkRkRsRkRs)"
    shows "(gen_set emp ins,set)Rklist_relRkRs"
    apply (intro fun_relI)
    unfolding gen_set_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst fold_set[where s="{}",simplified,symmetric])
    apply parametricity
    done
    
  lemma ball_isEmpty: "op_set_isEmpty s = (xs. False)"
    by auto

  definition gen_isEmpty :: "('s  ('k  bool)  bool)  's  bool" where
    "gen_isEmpty ball s  ball s (λ_. False)"

  lemma gen_isEmpty[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ball Ball (RkRs  (RkId)  Id)"
    shows "(gen_isEmpty ball,op_set_isEmpty)  RkRs  Id"
    apply (intro fun_relI)
    unfolding gen_isEmpty_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_isEmpty)
    apply parametricity
    done
  
  lemma foldli_size_abort_aux:
    "n0m; distinct l  
      foldli l (λn. n<m) (λ_ n. Suc n) n0 = min m (n0 + card (set l))"
    apply (induct l arbitrary: n0)
    apply auto
    done

  lemma foldli_size_abort: "
    det_fold_set X (λn. n<m) (λ_ n. Suc n) 0 (op_set_size_abort m)"
    apply rule
    using foldli_size_abort_aux[where ?n0.0=0]
    by simp

  definition gen_size_abort where
    "gen_size_abort it m s  it s (λn. n<m) (λ_ n. Suc n) 0"

  lemma gen_size_abort[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_size_abort (λx. foldli (it x)),op_set_size_abort) 
     Id  RkRs  Id"
    apply (intro fun_relI)
    unfolding gen_size_abort_def 
    apply (rule det_fold_set[OF foldli_size_abort IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done
    
  lemma size_abort_isSng: "op_set_isSng s  op_set_size_abort 2 s = 1"
    by auto 

  definition gen_isSng :: "(nat  's  nat)  _" where
    "gen_isSng sizea s  sizea 2 s = 1"

  lemma gen_isSng[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP sizea op_set_size_abort (Id  (RkRs)  Id)"
    shows "(gen_isSng sizea,op_set_isSng)  RkRs  Id"
    apply (intro fun_relI)
    unfolding gen_isSng_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst size_abort_isSng)
    apply parametricity
    done
    
  lemma foldli_disjoint_aux:
    "foldli l1 (λx. x) (λx _. ¬xs2) b  b  op_set_disjoint (set l1) s2"
    by (induct l1 arbitrary: b) auto

  lemma foldli_disjoint: 
    "det_fold_set X (λx. x) (λx _. ¬xs2) True (λs1. op_set_disjoint s1 s2)"
    apply rule using foldli_disjoint_aux[where b=True] by simp

  definition gen_disjoint 
    :: "_  ('k's2bool)  _"
    where "gen_disjoint it1 mem2 s1 s2 
     it1 s1 (λx. x) (λx _. ¬mem2 x s2) True"

  lemma gen_disjoint[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes MEM: "GEN_OP mem2 (∈) (Rk  RkRs2  Id)"
    shows "(gen_disjoint (λx. foldli (it1 x)) mem2,op_set_disjoint) 
     RkRs1  RkRs2  Id"
    apply (intro fun_relI)
    unfolding gen_disjoint_def 
    apply (rule det_fold_set[OF foldli_disjoint IT[unfolded autoref_tag_defs]])
    using MEM unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_filter_aux:
    "foldli l (λ_. True) (λx s. if P x then insert x s else s) s0 
    = s0  op_set_filter P (set l)"
    by (induct l arbitrary: s0) auto

  lemma foldli_filter: 
    "det_fold_set X (λ_. True) (λx s. if P x then insert x s else s) {} 
      (op_set_filter P)"
    apply rule using foldli_filter_aux[where ?s0.0="{}"] by simp

  definition gen_filter
    where "gen_filter it1 emp2 ins2 P s1  
      it1 s1 (λ_. True) (λx s. if P x then ins2 x s else s) emp2"

  lemma gen_filter[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes INS: 
      "GEN_OP ins2 Set.insert (RkRkRs2RkRs2)"
    assumes EMPTY: 
      "GEN_OP empty2 {} (RkRs2)"
    shows "(gen_filter (λx. foldli (it1 x)) empty2 ins2,op_set_filter) 
     (RkId)  (RkRs1)  (RkRs2)"
    apply (intro fun_relI)
    unfolding gen_filter_def
    apply (rule det_fold_set[OF foldli_filter IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_image_aux:
    "foldli l (λ_. True) (λx s. insert (f x) s) s0
    = s0  f`(set l)"
    by (induct l arbitrary: s0) auto

  lemma foldli_image: 
    "det_fold_set X (λ_. True) (λx s. insert (f x) s) {} 
      ((`) f)"
    apply rule using foldli_image_aux[where ?s0.0="{}"] by simp

  definition gen_image
    where "gen_image it1 emp2 ins2 f s1  
      it1 s1 (λ_. True) (λx s. ins2 (f x) s) emp2"

  lemma gen_image[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes INS: 
      "GEN_OP ins2 Set.insert (Rk'Rk'Rs2Rk'Rs2)"
    assumes EMPTY: 
      "GEN_OP empty2 {} (Rk'Rs2)"
    shows "(gen_image (λx. foldli (it1 x)) empty2 ins2,(`)) 
     (RkRk')  (RkRs1)  (Rk'Rs2)"
    apply (intro fun_relI)
    unfolding gen_image_def
    apply (rule det_fold_set[OF foldli_image IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  (* TODO: Also do sel! *)

  lemma foldli_pick:
    assumes "l[]" 
    obtains x where "xset l" 
    and "(foldli l (case_option True (λ_. False)) (λx _. Some x) None) = Some x"
    using assms by (cases l) auto

  definition gen_pick where
    "gen_pick it s  
      (the (it s (case_option True (λ_. False)) (λx _. Some x) None))"

context begin interpretation autoref_syn .
  lemma gen_pick[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    assumes NE: "SIDE_PRECOND (s'{})"
    assumes SREF: "(s,s')RkRs"
    shows "(RETURN (gen_pick (λx. foldli (it x)) s), 
      (OP op_set_pick ::: RkRsRknres_rel)$s')Rknres_rel"
  proof -
    obtain tsl' where
      [param]: "(it s,tsl')  Rklist_rel" 
      and IT': "RETURN tsl'  it_to_sorted_list (λ_ _. True) s'"
      using IT[unfolded autoref_tag_defs is_set_to_list_def] SREF
      by (rule is_set_to_sorted_listE)

    from IT' NE have "tsl'[]" and [simp]: "s'=set tsl'" 
      unfolding it_to_sorted_list_def by simp_all
    then obtain x where "xs'" and
      "(foldli tsl' (case_option True (λ_. False)) (λx _. Some x) None) = Some x"
      (is "?fld = _")
      by (blast elim: foldli_pick)
    moreover 
    have "(RETURN (gen_pick (λx. foldli (it x)) s), RETURN (the ?fld)) 
       Rknres_rel"
      unfolding gen_pick_def
      apply (parametricity add: the_paramR)
      using ?fld = Some x
      by simp
    ultimately show ?thesis
      unfolding autoref_tag_defs
      apply -
      apply (drule nres_relD)
      apply (rule nres_relI)
      apply (erule ref_two_step)
      by simp
  qed
end

  definition gen_Sigma
    where "gen_Sigma it1 it2 empX insX s1 f2  
      it1 s1 (λ_. True) (λx s. 
        it2 (f2 x) (λ_. True) (λy s. insX (x,y) s) s
      ) empX
    "

  lemma foldli_Sigma_aux:
    fixes s :: "'s1_impl" and s':: "'k set"
    fixes f :: "'k_impl  's2_impl" and f':: "'k  'l set"
    fixes s0 :: "'kl_impl" and s0' :: "('k×'l) set"
    assumes IT1: "is_set_to_list Rk Rs1 it1"
    assumes IT2: "is_set_to_list Rl Rs2 it2"
    assumes INS: 
      "(insX, Set.insert)  
        (Rk,Rlprod_relRk,Rlprod_relRs3Rk,Rlprod_relRs3)"
    assumes S0R: "(s0, s0')  Rk,Rlprod_relRs3" 
    assumes SR: "(s, s')  RkRs1" 
    assumes FR: "(f, f')  Rk  RlRs2"
    shows "(foldli (it1 s) (λ_. True) (λx s. 
        foldli (it2 (f x)) (λ_. True) (λy s. insX (x,y) s) s
      ) s0,s0'  Sigma s' f') 
       Rk,Rlprod_relRs3"
  proof -
    have S: "x s f. Sigma (insert x s) f = ({x}×f x)  Sigma s f"
      by auto

    obtain l' where 
      IT1L: "(it1 s,l')Rklist_rel" 
      and SL: "s' = set l'"
      apply (rule 
        is_set_to_sorted_listE[OF IT1[unfolded is_set_to_list_def] SR])
      by (auto simp: it_to_sorted_list_def)

    show ?thesis
      unfolding SL
      using IT1L S0R
    proof (induct arbitrary: s0 s0' rule: list_rel_induct)
      case Nil thus ?case by simp
    next
      case (Cons x x' l l')

      obtain l2' where 
        IT2L: "(it2 (f x),l2')Rllist_rel" 
        and FXL: "f' x' = set l2'"
        apply (rule 
          is_set_to_sorted_listE[
            OF IT2[unfolded is_set_to_list_def], of "f x" "f' x'"
          ])
        apply (parametricity add: Cons.hyps(1) FR)
        by (auto simp: it_to_sorted_list_def)

      have "(foldli (it2 (f x)) (λ_. True) (λy. insX (x, y)) s0, 
        s0'  {x'}×f' x')  Rk,Rlprod_relRs3"
        unfolding FXL 
        using IT2L (s0, s0')  Rk, Rlprod_relRs3
        apply (induct  arbitrary: s0 s0' rule: list_rel_induct)
        apply simp
        apply simp
        apply (subst Un_insert_left[symmetric])
        apply (rprems)
        apply (parametricity add: INS (x,x')Rk)
        done

      show ?case
        apply simp
        apply (subst S)
        apply (subst Un_assoc[symmetric])
        apply (rule Cons.hyps)
        apply fact
        done
    qed
  qed


  lemma gen_Sigma[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT1: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes IT2: "SIDE_GEN_ALGO (is_set_to_list Rl Rs2 it2)"
    assumes EMPTY: 
      "GEN_OP empX {} (Rk,Rlprod_relRs3)"
    assumes INS: 
      "GEN_OP insX Set.insert 
         (Rk,Rlprod_relRk,Rlprod_relRs3Rk,Rlprod_relRs3)"
    shows "(gen_Sigma (λx. foldli (it1 x)) (λx. foldli (it2 x)) empX insX,Sigma) 
       (RkRs1)  (Rk  RlRs2)  Rk,Rlprod_relRs3"
    apply (intro fun_relI)
    unfolding gen_Sigma_def
    using foldli_Sigma_aux[OF 
      IT1[unfolded autoref_tag_defs]
      IT2[unfolded autoref_tag_defs]
      INS[unfolded autoref_tag_defs]
      EMPTY[unfolded autoref_tag_defs]
    ]
    by simp

lemma gen_cart:
  assumes PRIO_TAG_GEN_ALGO
  assumes [param]: "(sigma, Sigma)  (RxRsx  (Rx  RyRsy)  Rx ×r RyRsp)"
  shows "(λx y. sigma x (λ_. y), op_set_cart)  RxRsx  RyRsy  Rx ×r RyRsp"
  unfolding op_set_cart_def[abs_def]
  by parametricity
lemmas [autoref_rules] = gen_cart[OF _ GEN_OP_D]


context begin interpretation autoref_syn .

  lemma op_set_to_sorted_list_autoref[autoref_rules]:
    assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "(λsi. RETURN (tsl si),  OP (op_set_to_sorted_list ordR)) 
       RkRs  Rklist_relnres_rel"
    using assms
    apply (intro fun_relI nres_relI)
    apply simp
    apply (rule RETURN_SPEC_refine)
    apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
    done

  lemma op_set_to_list_autoref[autoref_rules]:
    assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "(λsi. RETURN (tsl si), op_set_to_list) 
       RkRs  Rklist_relnres_rel"
    using assms
    apply (intro fun_relI nres_relI)
    apply simp
    apply (rule RETURN_SPEC_refine)
    apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
    done

end

lemma foldli_Union: "det_fold_set X (λ_. True) (∪) {} Union"
proof (rule, goal_cases)
  case (1 l)
  have "a. foldli l (λ_. True) (∪) a = a  (set l)"
    by (induct l) auto
  thus ?case by auto
qed

definition gen_Union
  :: "_  's3  ('s2  's3  's3) 
       's1  's3"
  where 
  "gen_Union it emp un X  it X (λ_. True) un emp"

lemma gen_Union[autoref_rules_raw]:
  assumes PRIO_TAG_GEN_ALGO
  assumes EMP: "GEN_OP emp {} (RkRs3)"
  assumes UN: "GEN_OP un (∪) (RkRs2RkRs3RkRs3)"
  assumes IT: "SIDE_GEN_ALGO (is_set_to_list (RkRs2) Rs1 tsl)"
  shows "(gen_Union (λx. foldli (tsl x)) emp un,Union)  RkRs2Rs1  RkRs3"
  apply (intro fun_relI)
  unfolding gen_Union_def 
  apply (rule det_fold_set[OF 
    foldli_Union IT[unfolded autoref_tag_defs]])
  using EMP UN
  unfolding autoref_tag_defs
  apply (parametricity)+
  done

definition "atLeastLessThan_impl a b  do {
  (_,r)  WHILET (λ(i,r). i<b) (λ(i,r). RETURN (i+1, insert i r)) (a,{});
  RETURN r
}"

lemma atLeastLessThan_impl_correct: 
  "atLeastLessThan_impl a b  SPEC (λr. r = {a..<b::nat})"
  unfolding atLeastLessThan_impl_def
  apply (refine_rcg refine_vcg WHILET_rule[where 
    I = "λ(i,r). r = {a..<i}  ai  ((a<b  ib)  (¬a<b  i=a))"
    and R = "measure (λ(i,_). b - i)"
    ])
  by auto

schematic_goal atLeastLessThan_code_aux:
  notes [autoref_rules] = IdI[of a] IdI[of b]
  assumes [autoref_rules]: "(emp,{})Rs"
  assumes [autoref_rules]: "(ins,insert)nat_rel  Rs  Rs"
  shows "(?c, atLeastLessThan_impl) 
   nat_rel  nat_rel  Rsnres_rel"
  unfolding atLeastLessThan_impl_def[abs_def]
  apply (autoref (keep_goal))
  done
concrete_definition atLeastLessThan_code uses atLeastLessThan_code_aux

schematic_goal atLeastLessThan_tr_aux:
  "RETURN ?c  atLeastLessThan_code emp ins a b"
  unfolding atLeastLessThan_code_def
  by (refine_transfer (post))
concrete_definition atLeastLessThan_tr 
  for emp ins a b uses atLeastLessThan_tr_aux

lemma atLeastLessThan_gen[autoref_rules]: 
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP emp {} Rs"
  assumes "GEN_OP ins insert (nat_rel  Rs  Rs)"
  shows "(atLeastLessThan_tr emp ins, atLeastLessThan) 
     nat_rel  nat_rel  Rs"
proof (intro fun_relI, simp)
  fix a b
  from assms have GEN: 
    "(emp,{})Rs" "(ins,insert)nat_rel  Rs  Rs"
    by auto

  note atLeastLessThan_tr.refine[of emp ins a b]
  also note 
    atLeastLessThan_code.refine[OF GEN,param_fo, OF IdI IdI, THEN nres_relD]
  also note atLeastLessThan_impl_correct
  finally show "(atLeastLessThan_tr emp ins a b, {a..<b})  Rs"
    by (auto simp: pw_le_iff refine_pw_simps)
qed

end

Theory Gen_Map

section ‹\isaheader{Generic Map Algorithms}›
theory Gen_Map
imports "../Intf/Intf_Map" "../../Iterator/Iterator"
begin
  lemma map_to_set_distinct_conv:
    assumes "distinct tsl'" and "map_to_set m' = set tsl'"
    shows "distinct (map fst tsl')"
    apply (rule ccontr)
    apply (drule not_distinct_decomp)
    using assms
    apply (clarsimp elim!: map_eq_appendE)
    by (metis (hide_lams, no_types) insert_iff map_to_set_inj)


  (* TODO: Make foldli explicit, such that it is seen by 
  iterator-optimizations! cf Gen_Set for how to do this! *)
  lemma foldli_add: "det_fold_map X 
    (λ_. True) (λ(k,v) m. op_map_update k v m) m ((++) m)"
  proof (rule, goal_cases)
    case (1 l) thus ?case
      apply (induct l arbitrary: m) 
      apply (auto simp: map_of_distinct_upd[symmetric])
      done
  qed

  definition gen_add
    :: "('s2  _)  ('k  'v  's1  's1)  's1  's2  's1"
    where 
    "gen_add it upd A B  it B (λ_. True) (λ(k,v) m. upd k v m) A"

  lemma gen_add[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes UPD: "GEN_OP ins op_map_update (RkRvRk,RvRs1Rk,RvRs1)"
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs2 tsl)"
    shows "(gen_add (foldli o tsl) ins,(++)) 
       (Rk,RvRs1)  (Rk,RvRs2)  (Rk,RvRs1)"
    apply (intro fun_relI)
    unfolding gen_add_def comp_def
    apply (rule det_fold_map[OF foldli_add IT[unfolded autoref_tag_defs]])
    apply (parametricity add: UPD[unfolded autoref_tag_defs])+
    done

  lemma foldli_restrict: "det_fold_map X (λ_. True) 
    (λ(k,v) m. if P (k,v) then op_map_update k v m else m) Map.empty
      (op_map_restrict P )" (is "det_fold_map _ _ ?f _ _")
  proof -
    {
      fix l m
      have "distinct (map fst l) 
        foldli l (λ_. True) ?f m = m ++ op_map_restrict P (map_of l)"
      proof (induction l arbitrary: m) 
        case Nil thus ?case by simp
      next
        case (Cons kv l)
        obtain k v where [simp]: "kv = (k,v)" by fastforce
        from Cons.prems have 
          DL: "distinct (map fst l)" and KNI: "k  set (map fst l)" 
          by auto

        show ?case proof (cases "P (k,v)")
          case [simp]: True 
          have "foldli (kv#l) (λ_. True) ?f m = foldli l (λ_. True) ?f (m(kv))"
            by simp
          also from Cons.IH[OF DL] have 
            " = m(kv) ++ op_map_restrict P (map_of l)" .
          also have " = m ++ op_map_restrict P (map_of (kv#l))"
            using KNI
            by (auto
              split: option.splits
              intro!: ext 
              simp: Map.restrict_map_def Map.map_add_def
              simp: map_of_eq_None_iff[symmetric])
          finally show ?thesis .
        next
          case [simp]: False 
          have "foldli (kv#l) (λ_. True) ?f m = foldli l (λ_. True) ?f m"
            by simp
          also from Cons.IH[OF DL] have 
            " = m ++ op_map_restrict P (map_of l)" .
          also have " = m ++ op_map_restrict P (map_of (kv#l))"
            using KNI
            by (auto 
              intro!: ext
              simp: Map.restrict_map_def Map.map_add_def
              simp: map_of_eq_None_iff[symmetric]
            )
          finally show ?thesis .
        qed
      qed
    } 
    from this[of _ Map.empty] show ?thesis
      by (auto intro!: det_fold_mapI)
  qed

  definition gen_restrict :: "('s1  _)  _"
    where "gen_restrict it upd emp P m 
     it m (λ_. True) (λ(k,v) m. if P (k,v) then upd k v m else m) emp"

  lemma gen_restrict[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs1 tsl)"
    assumes INS: 
      "GEN_OP upd op_map_update (RkRvRk,RvRs2Rk,RvRs2)"
    assumes EMPTY: 
      "GEN_OP emp Map.empty (Rk,RvRs2)"
    shows "(gen_restrict (foldli o tsl) upd emp,op_map_restrict) 
     (Rk,Rvprod_rel  Id)  (Rk,RvRs1)  (Rk,RvRs2)"
    apply (intro fun_relI)
    unfolding gen_restrict_def comp_def
    apply (rule det_fold_map[OF foldli_restrict IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma fold_map_of: 
    "fold (λ(k,v) s. op_map_update k v s) (rev l) Map.empty = map_of l"
  proof -
    {
      fix m
      have "fold (λ(k,v) s. s(kv)) (rev l) m = m ++ map_of l"
        apply (induct l arbitrary: m)
        apply auto
        done
    } thus ?thesis by simp
  qed

  definition gen_map_of :: "'m  ('k'v'm'm)  _" where 
    "gen_map_of emp upd l  fold (λ(k,v) s. upd k v s) (rev l) emp"


  lemma gen_map_of[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes UPD: "GEN_OP upd op_map_update (RkRvRk,RvRmRk,RvRm)"
    assumes EMPTY: "GEN_OP emp Map.empty (Rk,RvRm)"
    shows "(gen_map_of emp upd,map_of)  Rk,Rvprod_rellist_rel  Rk,RvRm"
    using assms
    apply (intro fun_relI)
    unfolding gen_map_of_def[abs_def]
    unfolding autoref_tag_defs
    apply (subst fold_map_of[symmetric])
    apply parametricity
    done

  lemma foldli_ball_aux: 
    "distinct (map fst l)  foldli l (λx. x) (λx _. P x) b 
     b  op_map_ball (map_of l) P"
    apply (induct l arbitrary: b)
    apply simp
    apply (force simp: map_to_set_map_of image_def)
    done
  
  lemma foldli_ball: 
    "det_fold_map X (λx. x) (λx _. P x) True (λm. op_map_ball m P)"
    apply rule
    using foldli_ball_aux[where b=True] by auto
    
  definition gen_ball :: "('m  _)  _" where
    "gen_ball it m P  it m (λx. x) (λx _. P x) True"

  lemma gen_ball[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
    shows "(gen_ball (foldli o tsl),op_map_ball) 
     Rk,RvRm  (Rk,Rvprod_rel  Id)  Id"
    apply (intro fun_relI)
    unfolding gen_ball_def comp_def
    apply (rule det_fold_map[OF foldli_ball IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma foldli_bex_aux: 
    "distinct (map fst l)  foldli l (λx. ¬x) (λx _. P x) b 
     b  op_map_bex (map_of l) P"
    apply (induct l arbitrary: b)
    apply simp
    apply (force simp: map_to_set_map_of image_def)
    done
  
  lemma foldli_bex: 
    "det_fold_map X (λx. ¬x) (λx _. P x) False (λm. op_map_bex m P)"
    apply rule
    using foldli_bex_aux[where b=False] by auto

  definition gen_bex :: "('m  _)  _" where
    "gen_bex it m P  it m (λx. ¬x) (λx _. P x) False"

  lemma gen_bex[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
    shows "(gen_bex (foldli o tsl),op_map_bex) 
     Rk,RvRm  (Rk,Rvprod_rel  Id)  Id"
    apply (intro fun_relI)
    unfolding gen_bex_def comp_def
    apply (rule det_fold_map[OF foldli_bex IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma ball_isEmpty: "op_map_isEmpty m = op_map_ball m (λ_. False)"
    apply (auto intro!: ext)
    by (metis map_to_set_simps(7) option.exhaust)

  definition "gen_isEmpty ball m  ball m (λ_. False)"

  lemma gen_isEmpty[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes BALL: 
      "GEN_OP ball op_map_ball (Rk,RvRm(Rk,Rvprod_relId)  Id)"
    shows "(gen_isEmpty ball,op_map_isEmpty) 
     Rk,RvRm  Id"
    apply (intro fun_relI)
    unfolding gen_isEmpty_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_isEmpty)
    apply parametricity+
    done
  
  lemma foldli_size_aux: "distinct (map fst l) 
     foldli l (λ_. True) (λ_ n. Suc n) n = n + op_map_size (map_of l)"
    apply (induct l arbitrary: n)
    apply (auto simp: dom_map_of_conv_image_fst)
    done

  lemma foldli_size: "det_fold_map X (λ_. True) (λ_ n. Suc n) 0 op_map_size"
    apply rule
    using foldli_size_aux[where n=0] by simp

  definition gen_size :: "('m  _)  _"
    where "gen_size it m  it m (λ_. True) (λ_ n. Suc n) 0"

  lemma gen_size[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
    shows "(gen_size (foldli o tsl),op_map_size)  Rk,RvRm  Id"
    apply (intro fun_relI)
    unfolding gen_size_def comp_def
    apply (rule det_fold_map[OF foldli_size IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done
  
  lemma foldli_size_abort_aux:
    "n0m; distinct (map fst l)  
      foldli l (λn. n<m) (λ_ n. Suc n) n0 = min m (n0 + card (dom (map_of l)))"
    apply (induct l arbitrary: n0)
    apply (auto simp: dom_map_of_conv_image_fst)
    done

  lemma foldli_size_abort: 
    "det_fold_map X (λn. n<m) (λ_ n. Suc n) 0 (op_map_size_abort m)"
    apply rule
    using foldli_size_abort_aux[where ?n0.0=0]
    by simp

  definition gen_size_abort :: "('s  _)  _" where
    "gen_size_abort it m s  it s (λn. n<m) (λ_ n. Suc n) 0"

  lemma gen_size_abort[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm tsl)"
    shows "(gen_size_abort (foldli o tsl),op_map_size_abort) 
       Id  Rk,RvRm  Id"
    apply (intro fun_relI)
    unfolding gen_size_abort_def comp_def
    apply (rule det_fold_map[OF foldli_size_abort 
      IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done
  
  lemma size_abort_isSng: "op_map_isSng s  op_map_size_abort 2 s = 1"
    by (auto simp: dom_eq_singleton_conv min_def dest!: card_eq_SucD)

  definition gen_isSng :: "(nat  's  nat)  _" where
    "gen_isSng sizea s  sizea 2 s = 1"

  lemma gen_isSng[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP sizea op_map_size_abort (Id  (Rk,RvRm)  Id)"
    shows "(gen_isSng sizea,op_map_isSng) 
     Rk,RvRm  Id"
    apply (intro fun_relI)
    unfolding gen_isSng_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst size_abort_isSng)
    apply parametricity
    done


  (* TODO: Also do sel! *)

  lemma foldli_pick:
    assumes "l[]" 
    obtains k v where "(k,v)set l" 
    and "(foldli l (case_option True (λ_. False)) (λx _. Some x) None) 
      = Some (k,v)"
    using assms by (cases l) auto

  definition gen_pick where
    "gen_pick it s  
      (the (it s (case_option True (λ_. False)) (λx _. Some x) None))"



context begin interpretation autoref_syn .

  lemma gen_pick[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rm it)"
    assumes NE: "SIDE_PRECOND (m'Map.empty)"
    assumes SREF: "(m,m')Rk,RvRm"
    shows "(RETURN (gen_pick (λx. foldli (it x)) m), 
      (OP op_map_pick ::: Rk,RvRmRk×rRvnres_rel)$m')Rk×rRvnres_rel"
  proof -
    thm is_map_to_list_def is_map_to_sorted_listE

    obtain tsl' where
      [param]: "(it m,tsl')  Rk×rRvlist_rel" 
      and IT': "RETURN tsl'  it_to_sorted_list (λ_ _. True) (map_to_set m')"
      using IT[unfolded autoref_tag_defs is_map_to_list_def] SREF
      by (auto intro: is_map_to_sorted_listE)

    from IT' NE have "tsl'[]" and [simp]: "m'=map_of tsl'" 
      and DIS': "distinct (map fst tsl')"
      unfolding it_to_sorted_list_def 
      apply simp_all
      apply (metis empty_set map_to_set_empty_iff(1))
      apply (metis map_of_map_to_set map_to_set_distinct_conv)
      apply (metis map_to_set_distinct_conv)
      done

    then obtain k v where "m' k = Some v" and
      "(foldli tsl' (case_option True (λ_. False)) (λx _. Some x) None) 
        = Some (k,v)"
      (is "?fld = _")
      by (cases rule: foldli_pick) auto
    moreover 
    have "(RETURN (gen_pick (λx. foldli (it x)) m), RETURN (the ?fld)) 
       Rk×rRvnres_rel"
      unfolding gen_pick_def
      apply (parametricity add: the_paramR)
      using ?fld = Some (k,v)
      by simp
    ultimately show ?thesis
      unfolding autoref_tag_defs
      apply -
      apply (drule nres_relD)
      apply (rule nres_relI)
      apply (erule ref_two_step)
      by simp
  qed
end


  definition "gen_map_pick_remove pick del m  do {
    (k,v)pick m;
    let m = del k m;
    RETURN ((k,v),m)
    }"
  
context begin interpretation autoref_syn .
  lemma gen_map_pick_remove
    [unfolded gen_map_pick_remove_def, autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes PICK: "SIDE_GEN_OP (
      (pick m, 
      (OP op_map_pick ::: Rk,RvRm  Rk×rRvnres_rel)$m') 
      Rk×rRvnres_rel)"
    assumes DEL: "GEN_OP del op_map_delete (Rk  Rk,RvRm  Rk,RvRm)"
    assumes [param]: "(m,m')Rk,RvRm"
    shows "(gen_map_pick_remove pick del m, 
      (OP op_map_pick_remove 
        ::: Rk,RvRm  (Rk×rRv) ×r Rk,RvRmnres_rel)$m')
       (Rk×rRv) ×r Rk,RvRmnres_rel"
  proof -
    note [param] = 
      PICK[unfolded autoref_tag_defs] 
      DEL[unfolded autoref_tag_defs]

    have "(gen_map_pick_remove pick del m, 
      do {    
        (k,v)op_map_pick m';
        let m' = op_map_delete k m';
        RETURN ((k,v),m')
      })  (Rk×rRv) ×r Rk,RvRmnres_rel" (is "(_,?h):_")
      unfolding gen_map_pick_remove_def[abs_def]
      apply parametricity
      done
    also have "?h = op_map_pick_remove m'"
      by (auto simp add: pw_eq_iff refine_pw_simps)
    finally show ?thesis by simp
  qed
end


end

Theory Gen_Map2Set

section ‹\isaheader{Generic Map To Set Converter}›
theory Gen_Map2Set
imports 
  "../Intf/Intf_Map"
  "../Intf/Intf_Set"
  "../Intf/Intf_Comp"
  "../../Iterator/Iterator"
begin

lemma map_fst_unit_distinct_eq[simp]:
  fixes l :: "('k×unit) list"
  shows "distinct (map fst l)  distinct l"
  by (induct l) auto

definition 
  map2set_rel :: "
    (('ki×'k) set  (unit×unit) set  ('mi×('kunit))set)  
    ('ki×'k) set  
    ('mi×('k set)) set"
  where 
  map2set_rel_def_internal: 
  "map2set_rel R Rk  Rk,Id::(unit×_) setR O {(m,dom m)| m. True}"

lemma map2set_rel_def: "Rk(map2set_rel R) 
  = Rk,Id::(unit×_) setR O {(m,dom m)| m. True}"
  unfolding map2set_rel_def_internal[abs_def] by (simp add: relAPP_def)

lemma map2set_relI:
  assumes "(s,m')Rk,IdR" and "s'=dom m'"
  shows "(s,s')Rkmap2set_rel R"
  using assms unfolding map2set_rel_def by blast

lemma map2set_relE:
  assumes "(s,s')Rkmap2set_rel R"
  obtains m' where "(s,m')Rk,IdR" and "s'=dom m'"
  using assms unfolding map2set_rel_def by blast

lemma map2set_rel_sv[relator_props]:
  "single_valued (Rk,IdRm)  single_valued (Rkmap2set_rel Rm)"
  unfolding map2set_rel_def
  by (auto intro: single_valuedI dest: single_valuedD)

lemma map2set_empty[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP e op_map_empty (Rk,IdR)"
  shows "(e,{})Rkmap2set_rel R"
  using assms
  unfolding map2set_rel_def
  by auto

lemmas [autoref_rel_intf] = 
  REL_INTFI[of "map2set_rel R" i_set] for R


definition "map2set_insert i k s  i k () s"
lemma map2set_insert[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP i op_map_update (Rk  Id  Rk,IdR  Rk,IdR)"
  shows 
    "(map2set_insert i,Set.insert)RkRkmap2set_rel R  Rkmap2set_rel R"
  using assms
  unfolding map2set_rel_def map2set_insert_def[abs_def]
  by (force dest: fun_relD)

definition "map2set_memb l k s  case l k s of None  False | Some _  True"
lemma map2set_memb[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP l op_map_lookup (Rk  Rk,IdR  Idoption_rel)"
  shows "(map2set_memb l ,(∈))
     RkRkmap2set_rel RId"
  using assms
  unfolding map2set_rel_def map2set_memb_def[abs_def]
  by (force dest: fun_relD split: option.splits)
  
lemma map2set_delete[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP d op_map_delete (RkRk,IdRRk,IdR)"
  shows "(d,op_set_delete)RkRkmap2set_rel RRkmap2set_rel R"
  using assms
  unfolding map2set_rel_def
  by (force dest: fun_relD)

lemma map2set_to_sorted_list[autoref_ga_rules]:
  fixes it :: "'m  ('k×unit) list"
  assumes A: "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Id R it)"
  shows "is_set_to_sorted_list ordR Rk (map2set_rel R) 
    (it_to_list (map_iterator_dom o (foldli o it)))"
proof -
  { 
    fix l::"('k×unit) list"
    have "l0. foldli l (λ_. True) (λx σ. σ @ [fst x]) l0 = l0@map fst l"
      by (induct l) auto
  }
  hence S: "it_to_list (map_iterator_dom o (foldli o it)) = map fst o it"
    unfolding it_to_list_def[abs_def] map_iterator_dom_def[abs_def]
      set_iterator_image_def set_iterator_image_filter_def
    by (auto)
  show ?thesis
    unfolding S
    using assms
    unfolding is_map_to_sorted_list_def is_set_to_sorted_list_def
    apply clarsimp
    apply (erule map2set_relE)
    apply (drule spec, drule spec)
    apply (drule (1) mp)
    apply (elim exE conjE)
    apply (rule_tac x="map fst l'" in exI)
    apply (rule conjI)
    apply parametricity

    unfolding it_to_sorted_list_def
    apply (simp add: map_to_set_dom)
    apply (simp add: sorted_wrt_map key_rel_def[abs_def])
    done
qed

lemma map2set_to_list[autoref_ga_rules]:
  fixes it :: "'m  ('k×unit) list"
  assumes A: "GEN_ALGO_tag (is_map_to_list Rk Id R it)"
  shows "is_set_to_list Rk (map2set_rel R) 
    (it_to_list (map_iterator_dom o (foldli o it)))"
  using assms unfolding is_set_to_list_def is_map_to_list_def
  by (rule map2set_to_sorted_list)


(*lemma map2set_it_simp[iterator_simps]:
  "foldli ((map fst o it) x) c f s = foldli (it x) c (λ(k,v) s. f k s) s" 
  by (simp add: foldli_map comp_def fn_fst_conv)
*)

text ‹Transfering also non-basic operations results in specializations
  of map-algorithms to also be used for sets›
lemma map2set_union[autoref_rules_raw]:
  assumes "MINOR_PRIO_TAG (- 9)"
  assumes "GEN_OP u (++) (Rk,IdRRk,IdRRk,IdR)"
  shows "(u,(∪))Rkmap2set_rel RRkmap2set_rel RRkmap2set_rel R"
  using assms
  unfolding map2set_rel_def
  by (force dest: fun_relD)

lemmas [autoref_ga_rules] = cmp_unit_eq_linorder 
lemmas [autoref_rules_raw] = param_cmp_unit

lemma cmp_lex_zip_unit[simp]:
  "cmp_lex (cmp_prod cmp cmp_unit) (map (λk. (k, ())) l)
           (map (λk. (k, ())) m) =
          cmp_lex cmp l m"
  apply (induct cmp l m rule: cmp_lex.induct)
  apply (auto split: comp_res.split)
  done

lemma cmp_img_zip_unit[simp]:
  "cmp_img (λm. map (λk. (k,())) (f m)) (cmp_lex (cmp_prod cmp1 cmp_unit))
    = cmp_img f (cmp_lex cmp1)"
  unfolding cmp_img_def[abs_def]
  apply (intro ext)
  apply simp
  done

(* TODO: Move *)

lemma map2set_finite[relator_props]:
  assumes "finite_map_rel (Rk,IdR)"
  shows "finite_set_rel (Rkmap2set_rel R)"
  using assms
  unfolding map2set_rel_def finite_set_rel_def finite_map_rel_def
  by auto

lemma map2set_cmp[autoref_rules_raw]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmpk)"
  assumes MPAR:
    "GEN_OP cmp (cmp_map cmpk cmp_unit) (Rk,IdR  Rk,IdR  Id)"
  assumes FIN: "PREFER finite_map_rel (Rk, IdR)"
  shows "(cmp,cmp_set cmpk)Rkmap2set_rel R  Rkmap2set_rel R  Id"
proof -
  interpret linorder "comp2le cmpk" "comp2lt cmpk"
    using ELO by (simp add: eq_linorder_class_conv)

  show ?thesis
    using MPAR
    unfolding cmp_map_def cmp_set_def
    apply simp
    apply parametricity
    apply (drule cmp_extend_paramD)
    apply (insert FIN, fastforce simp add: finite_map_rel_def) []
    apply (simp add: sorted_list_of_map_def[abs_def])
    apply (auto simp: map2set_rel_def cmp_img_def[abs_def] dest: fun_relD) []

    apply (insert map2set_finite[OF FIN[unfolded autoref_tag_defs]],
      fastforce simp add: finite_set_rel_def)
    done
qed

end

Theory Gen_Comp

section ‹\isaheader{Generic Compare Algorithms}›
theory Gen_Comp
imports 
  "../Intf/Intf_Comp"
  Automatic_Refinement.Automatic_Refinement
  "HOL-Library.Product_Lexorder"
begin

subsection ‹Order for Product›
(* TODO: Optimization? Or only go via prod_cmp? *)
lemma autoref_prod_cmp_dflt_id[autoref_rules_raw]: 
  "(dflt_cmp (≤) (<), dflt_cmp (≤) (<)) 
    Id,Idprod_rel  Id,Idprod_rel  Id"
  by auto

lemma gen_prod_cmp_dflt[autoref_rules_raw]:
  assumes PRIO_TAG_GEN_ALGO
  assumes "GEN_OP cmp1 (dflt_cmp (≤) (<)) (R1  R1  Id)"
  assumes "GEN_OP cmp2 (dflt_cmp (≤) (<)) (R2  R2  Id)"
  shows "(cmp_prod cmp1 cmp2, dflt_cmp (≤) (<)) 
    R1,R2prod_rel  R1,R2prod_rel  Id"
proof -
  have E: "dflt_cmp (≤) (<) 
    = cmp_prod (dflt_cmp (≤) (<)) (dflt_cmp (≤) (<))"
    by (auto simp: dflt_cmp_def prod_less_def prod_le_def intro!: ext)

  show ?thesis
    using assms
    unfolding autoref_tag_defs E
    by parametricity
qed


end

Theory GenCF_Impl_Chapter

(*<*)
theory GenCF_Impl_Chapter imports Main begin 
(*>*)
text_raw ‹\isasection{Implementations}›
(*<*)
end
(*>*)

Theory Impl_Array_Stack

section ‹Stack by Array›
theory Impl_Array_Stack
imports   
  Automatic_Refinement.Automatic_Refinement
  "../../Lib/Diff_Array"
begin

type_synonym 'a array_stack = "'a array × nat"

term Diff_Array.array_length

definition "as_raw_α s  take (snd s) (list_of_array (fst s))"
definition "as_raw_invar s  snd s  array_length (fst s)"

definition as_rel_def_internal: "as_rel R  br as_raw_α as_raw_invar O Rlist_rel"
lemma as_rel_def: "Ras_rel  br as_raw_α as_raw_invar O Rlist_rel"
  unfolding as_rel_def_internal[abs_def] by (simp add: relAPP_def)

lemma [relator_props]: "single_valued R  single_valued (Ras_rel)"
  unfolding as_rel_def
  by tagged_solver

lemmas [autoref_rel_intf] = REL_INTFI[of as_rel i_list]


definition "as_empty (_::unit)  (array_of_list [],0)"

lemma as_empty_refine[autoref_rules]: "(as_empty (),[])  Ras_rel"
  unfolding as_rel_def as_empty_def br_def
  unfolding as_raw_α_def as_raw_invar_def
  by auto


definition "as_push s x  let
    (a,n)=s;
    a = if n = array_length a then
        array_grow a (max 4 (2*n)) x
      else a;
    a = array_set a n x
  in
    (a,n+1)"

lemma as_push_refine[autoref_rules]: 
  "(as_push,op_list_append_elem)  Ras_rel  R  Ras_rel"
  apply (intro fun_relI)
  apply (simp add: as_push_def op_list_append_elem_def as_rel_def br_def
    as_raw_α_def as_raw_invar_def)
  apply clarsimp
  apply safe
  apply (rule)
  apply auto []
  apply (clarsimp simp: array_length_list) []
  apply parametricity

  apply rule
  apply auto []
  apply (auto simp: take_Suc_conv_app_nth array_length_list list_update_append) []
  apply parametricity
  done

term array_shrink

definition "as_shrink s  let 
    (a,n) = s;
    a = if 128*n  array_length a  n>4 then
        array_shrink a n
      else a
  in
    (a,n)"

lemma as_shrink_id_refine: "(as_shrink,id)  Ras_rel  Ras_rel"
  apply (intro fun_relI)
  apply (simp add: as_shrink_def as_rel_def br_def
    as_raw_α_def as_raw_invar_def Let_def)
  apply clarsimp
  apply safe

  apply (rule)
  apply (auto simp: array_length_list)
  done

lemma as_shrinkI:
  assumes [param]: "(s,a)Ras_rel"
  shows "(as_shrink s,a)Ras_rel"
  apply (subst id_apply[of a,symmetric])
  apply (parametricity add: as_shrink_id_refine)
  done

definition "as_pop s  let (a,n)=s in as_shrink (a,n - 1)"

lemma as_pop_refine[autoref_rules]: "(as_pop,butlast)  Ras_rel  Ras_rel"
  apply (intro fun_relI)
  apply (clarsimp simp add: as_pop_def split: prod.split)
  apply (rule as_shrinkI)

  apply (simp add: as_pop_def as_rel_def br_def
    as_raw_α_def as_raw_invar_def Let_def)
  apply clarsimp

  apply rule
  apply (auto simp: array_length_list) []
  apply (clarsimp simp: array_length_list take_minus_one_conv_butlast) []
  apply parametricity
  done
  
definition "as_get s i  let (a,_::nat)=s in array_get a i"

lemma as_get_refine: 
  assumes 1: "i'<length l" 
  assumes 2: "(a,l)Ras_rel" 
  assumes 3[param]: "(i,i')nat_rel"
  shows "(as_get a i,l!i')R"
  using 2
  apply (clarsimp 
    simp add: as_get_def as_rel_def br_def as_raw_α_def as_raw_invar_def
    split: prod.split)
  apply (rename_tac aa bb)
  apply (case_tac aa, simp)
proof -
  fix n cl
  assume TKR[param]: "(take n cl, l)  Rlist_rel"

  have "(take n cl!i, l!i')R"
    by parametricity (rule 1)
  also have "take n cl!i = cl!i"
    using 1 3 list_rel_imp_same_length[OF TKR]
    by simp
  finally show "(cl!i,l!i')R" .
qed
  
context begin interpretation autoref_syn .
lemma as_get_autoref[autoref_rules]: 
  assumes "(l,l')Ras_rel"
  assumes "(i,i')Id"
  assumes "SIDE_PRECOND (i' < length l')"
  shows "(as_get l i,(OP nth ::: Ras_rel  nat_rel  R)$l'$i')R"
  using assms by (simp add: as_get_refine)

definition "as_set s i x  let (a,n::nat)=s in (array_set a i x,n)"

lemma as_set_refine[autoref_rules]: 
  "(as_set,list_update)Ras_rel  nat_rel  R  Ras_rel"
  apply (intro fun_relI)
  apply (clarsimp 
    simp: as_set_def as_rel_def br_def as_raw_α_def as_raw_invar_def
    split: prod.split)
  apply rule
  apply auto []
  apply parametricity
  by simp

definition as_length :: "'a array_stack  nat" where 
  "as_length = snd"

lemma as_length_refine[autoref_rules]: 
  "(as_length,length)  Ras_rel  nat_rel"
  by (auto 
    simp: as_length_def as_rel_def br_def as_raw_α_def as_raw_invar_def
      array_length_list
    dest!: list_rel_imp_same_length
  )

definition "as_top s  as_get s (as_length s - 1)"

lemma as_top_code[code]: "as_top s = (let (a,n)=s in array_get a (n - 1))"
  unfolding as_top_def as_get_def as_length_def 
  by (auto split: prod.split)

lemma as_top_refine: "l[]; (s,l)Ras_rel  (as_top s,last l)R"
  unfolding as_top_def
  apply (simp add: last_conv_nth)
  apply (rule as_get_refine)
  apply (auto simp: as_length_def as_rel_def br_def as_raw_α_def 
    as_raw_invar_def array_length_list
    dest!: list_rel_imp_same_length)
  done

lemma as_top_autoref[autoref_rules]:
  assumes "(l,l')Ras_rel"
  assumes "SIDE_PRECOND (l'  [])"
  shows "(as_top l,(OP last ::: Ras_rel  R)$l')R"
  using assms by (simp add: as_top_refine)


definition "as_is_empty s  as_length s = 0"
lemma as_is_empty_code[code]: "as_is_empty s = (snd s = 0)"
  unfolding as_is_empty_def as_length_def by simp

lemma as_is_empty_refine[autoref_rules]: 
  "(as_is_empty,is_Nil)  Ras_rel  bool_rel"
proof
  fix s l
  assume [param]: "(s,l)Ras_rel"
  have "(as_is_empty s,length l = 0)  bool_rel"
    unfolding as_is_empty_def
    by (parametricity add: as_length_refine)
  also have "length l = 0  is_Nil l"
    by (cases l) auto
  finally show "(as_is_empty s, is_Nil l)  bool_rel" .
qed

definition "as_take m s  let (a,n) = s in 
  if m<n then 
    as_shrink (a,m)
  else (a,n)"

lemma as_take_refine[autoref_rules]: 
  "(as_take,take)nat_rel  Ras_rel  Ras_rel"
  apply (intro fun_relI)
  apply (clarsimp simp add: as_take_def, safe)

  apply (rule as_shrinkI)
  apply (simp add: as_rel_def br_def as_raw_α_def as_raw_invar_def)
  apply rule
  apply auto []
  apply clarsimp
  apply (subgoal_tac "take a' (list_of_array a) = take a' (take ba (list_of_array a))")
  apply (simp only: )
  apply (parametricity, rule IdI)
  apply simp

  apply (simp add: as_rel_def br_def as_raw_α_def as_raw_invar_def)
  apply rule
  apply auto []
  apply clarsimp
  apply (frule list_rel_imp_same_length)
  apply simp
  done

definition "as_singleton x  (array_of_list [x],1)"
lemma as_singleton_refine[autoref_rules]: 
  "(as_singleton,op_list_singleton)R  Ras_rel"
  apply (intro fun_relI)
  apply (simp add: as_singleton_def as_rel_def br_def as_raw_α_def 
    as_raw_invar_def)
  apply rule
  apply (auto simp: array_length_list) []
  apply simp
  done

end

end

Theory Impl_List_Set

section ‹\isaheader{List Based Sets}›
theory Impl_List_Set
imports
  "../../Iterator/Iterator" 
  "../Intf/Intf_Set" 
begin
  (* TODO: Move *)
  lemma list_all2_refl_conv:
    "list_all2 P xs xs  (xset xs. P x x)"
    by (induct xs) auto

  primrec glist_member :: "('a'abool)  'a  'a list  bool" where
    "glist_member eq x []  False"
  | "glist_member eq x (y#ys)  eq x y  glist_member eq x ys"

  lemma param_glist_member[param]: 
    "(glist_member,glist_member)(RaRaId)  Ra  Ralist_rel  Id"
    unfolding glist_member_def
    by (parametricity)

  lemma list_member_alt: "List.member = (λl x. glist_member (=) x l)"
  proof (intro ext)
    fix x l
    show "List.member l x = glist_member (=) x l"
      by (induct l) (auto simp: List.member_rec)
  qed

  thm List.insert_def
  definition 
    "glist_insert eq x xs = (if glist_member eq x xs then xs else x#xs)" 

  lemma param_glist_insert[param]:
    "(glist_insert, glist_insert)  (RRId)  R  Rlist_rel  Rlist_rel"
    unfolding glist_insert_def[abs_def]
    by (parametricity)


  primrec rev_append where
    "rev_append [] ac = ac"
  | "rev_append (x#xs) ac = rev_append xs (x#ac)"

  lemma rev_append_eq: "rev_append l ac = rev l @ ac"
    by (induct l arbitrary: ac) auto

  (*
  primrec glist_delete_aux1 :: "('a⇒'a⇒bool) ⇒ 'a ⇒ 'a list ⇒ 'a list" where
    "glist_delete_aux1 eq x [] = []"
  | "glist_delete_aux1 eq x (y#ys) = (
      if eq x y then 
        ys 
      else y#glist_delete_aux1 eq x ys)"

  primrec glist_delete_aux2 :: "('a⇒'a⇒_) ⇒ _" where
    "glist_delete_aux2 eq ac x [] = ac"
  | "glist_delete_aux2 eq ac x (y#ys) = (if eq x y then rev_append ys ac else
      glist_delete_aux2 eq (y#ac) x ys
    )"

  lemma glist_delete_aux2_eq1:
    "glist_delete_aux2 eq ac x l = rev (glist_delete_aux1 eq x l) @ ac"
    by (induct l arbitrary: ac) (auto simp: rev_append_eq)

  definition "glist_delete eq x l = glist_delete_aux2 eq [] x l"
  *)

  primrec glist_delete_aux :: "('a  'a  bool)  _" where
    "glist_delete_aux eq x [] as = as"
  | "glist_delete_aux eq x (y#ys) as = (
      if eq x y then rev_append as ys 
      else glist_delete_aux eq x ys (y#as)
    )"

  definition glist_delete where 
    "glist_delete eq x l  glist_delete_aux eq x l []"

  lemma param_glist_delete[param]:
    "(glist_delete, glist_delete)  (RRId)  R  Rlist_rel  Rlist_rel"
    unfolding glist_delete_def[abs_def]
      glist_delete_aux_def
      rev_append_def
    by (parametricity)


lemma list_rel_Range:
    "x'set l'. x'  Range R  l'  Range (Rlist_rel)"
proof (induction l')
  case Nil thus ?case by force
next
  case (Cons x' xs')
    then obtain xs where "(xs,xs')  R list_rel" by force
    moreover from Cons.prems obtain x where "(x,x')  R" by force
    ultimately have "(x#xs, x'#xs')  R list_rel" by simp
    thus ?case ..
qed

  text ‹All finite sets can be represented›
  lemma list_set_rel_range:
    "Range (Rlist_set_rel) = { S. finite S  SRange R }"
      (is "?A = ?B")
  proof (intro equalityI subsetI)
    fix s' assume "s'  ?A"
    then obtain l l' where A: "(l,l')  Rlist_rel" and
       B: "s' = set l'" and C: "distinct l'"
        unfolding list_set_rel_def br_def by blast
    moreover have "set l'  Range R"
        by (induction rule: list_rel_induct[OF A], auto)
    ultimately show "s'  ?B" by simp
  next
    fix s' assume A: "s'  ?B"
    then obtain l' where B: "set l' = s'" and C: "distinct l'"
        using finite_distinct_list by blast
    hence "(l',s')  br set distinct" by (simp add: br_def)
    
    moreover from A and B have "xset l'. x  Range R" by blast
    from list_rel_Range[OF this] obtain l
        where "(l,l')  Rlist_rel" by blast

    ultimately show "s'  ?A" unfolding list_set_rel_def by fast
  qed

  lemmas [autoref_rel_intf] = REL_INTFI[of list_set_rel i_set]

  lemma list_set_rel_finite[autoref_ga_rules]:
    "finite_set_rel (Rlist_set_rel)"
    unfolding finite_set_rel_def list_set_rel_def
    by (auto simp: br_def)

  lemma list_set_rel_sv[relator_props]:
    "single_valued R  single_valued (Rlist_set_rel)"
    unfolding list_set_rel_def
    by tagged_solver
    
  (* TODO: Move to Misc *)
  lemma Id_comp_Id: "Id O Id = Id" by simp

  lemma glist_member_id_impl: 
    "(glist_member (=), (∈))  Id  br set distinct  Id"
  proof (intro fun_relI, goal_cases)
    case (1 x x' l s') thus ?case
      by (induct l arbitrary: s') (auto simp: br_def)
  qed

  lemma glist_insert_id_impl:
    "(glist_insert (=), Set.insert)  Id  br set distinct  br set distinct"
  proof -
    have IC: "x s. insert x s = (if xs then s else insert x s)" by auto

    show ?thesis
      apply (intro fun_relI)
      apply (subst IC)
      unfolding glist_insert_def
      apply (parametricity add: glist_member_id_impl)
      apply (auto simp: br_def)
      done
  qed

  lemma glist_delete_id_impl:
    "(glist_delete (=), λx s. s-{x})
     Idbr set distinct  br set distinct"
  proof (intro fun_relI)
    fix x x':: 'a and s and s' :: "'a set"
    assume XREL: "(x, x')  Id" and SREL: "(s, s')  br set distinct"
    from XREL have [simp]: "x'=x" by simp

    {
      fix a and a' :: "'a set"
      assume "(a,a')br set distinct" and "s'  a' = {}"
      hence "(glist_delete_aux (=) x s a, s'-{x'}  a')br set distinct"
        using SREL
      proof (induction s arbitrary: a s' a')
        case Nil thus ?case by (simp add: br_def)
      next
        case (Cons y s) 
        show ?case proof (cases "x=y")
          case True with Cons show ?thesis 
            by (auto simp add: br_def rev_append_eq)
        next
          case False
          have "glist_delete_aux (=) x (y # s) a 
            = glist_delete_aux (=) x s (y#a)" by (simp add: False)
          also have "(,set s - {x'}  insert y a')br set distinct"
            apply (rule Cons.IH[of "y#a" "insert y a'" "set s"])
            using Cons.prems by (auto simp: br_def)
          also have "set s - {x'}  insert y a' = (s' - {x'})  a'"
          proof -
            from Cons.prems have [simp]: "s' = insert y (set s)"
              by (auto simp: br_def)
            show ?thesis using False by auto
          qed
          finally show ?thesis .
        qed
      qed
    }
    from this[of "[]" "{}"]     
    show "(glist_delete (=) x s, s' - {x'})  br set distinct"
      unfolding glist_delete_def
      by (simp add: br_def)
  qed
    
  lemma list_set_autoref_empty[autoref_rules]:
    "([],{})Rlist_set_rel"
    by (auto simp: list_set_rel_def br_def)

  lemma list_set_autoref_member[autoref_rules]:
    assumes "GEN_OP eq (=) (RRId)"
    shows "(glist_member eq,(∈))  R  Rlist_set_rel  Id"
    using assms
    apply (intro fun_relI)
    unfolding list_set_rel_def
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (subst Id_comp_Id[symmetric])
    apply (rule relcompI[rotated])
    apply (rule glist_member_id_impl[param_fo])
    apply (rule IdI)
    apply assumption
    apply parametricity
    done

  lemma list_set_autoref_insert[autoref_rules]:
    assumes "GEN_OP eq (=) (RRId)"
    shows "(glist_insert eq,Set.insert) 
       R  Rlist_set_rel  Rlist_set_rel"
    using assms
    apply (intro fun_relI)
    unfolding list_set_rel_def
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (rule relcompI[rotated])
    apply (rule glist_insert_id_impl[param_fo])
    apply (rule IdI)
    apply assumption
    apply parametricity
    done

  lemma list_set_autoref_delete[autoref_rules]:
    assumes "GEN_OP eq (=) (RRId)"
    shows "(glist_delete eq,op_set_delete) 
       R  Rlist_set_rel  Rlist_set_rel"
    using assms
    apply (intro fun_relI)
    unfolding list_set_rel_def
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (rule relcompI[rotated])
    apply (rule glist_delete_id_impl[param_fo])
    apply (rule IdI)
    apply assumption
    apply parametricity
    done
 
  lemma list_set_autoref_to_list[autoref_ga_rules]: 
    shows "is_set_to_sorted_list (λ_ _. True) R list_set_rel id"
    unfolding is_set_to_list_def is_set_to_sorted_list_def
      it_to_sorted_list_def list_set_rel_def br_def
    by auto

  lemma list_set_it_simp[refine_transfer_post_simp]:
    "foldli (id l) = foldli l" by simp

  lemma glist_insert_dj_id_impl:
    " xs; (l,s)br set distinct   (x#l,insert x s)br set distinct"
    by (auto simp: br_def)

context begin interpretation autoref_syn .
  lemma list_set_autoref_insert_dj[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes "SIDE_PRECOND_OPT (x's')"
    assumes "(x,x')R"
    assumes "(s,s')Rlist_set_rel"
    shows "(x#s,
      (OP Set.insert ::: R  Rlist_set_rel  Rlist_set_rel) $ x' $ s') 
       Rlist_set_rel"
    using assms
    unfolding autoref_tag_defs
    unfolding list_set_rel_def
    apply -
    apply (erule relcompE)
    apply (simp del: pair_in_Id_conv)
    apply (rule relcompI[rotated])
    apply (rule glist_insert_dj_id_impl)
    apply assumption
    apply assumption
    apply parametricity
    done
end

  subsection ‹More Operations›
  lemma list_set_autoref_isEmpty[autoref_rules]:
    "(is_Nil,op_set_isEmpty)  Rlist_set_rel  bool_rel"
    by (auto simp: list_set_rel_def br_def split: list.split_asm)

  lemma list_set_autoref_filter[autoref_rules]:
    "(filter,op_set_filter) 
       (R  bool_rel)  Rlist_set_rel  Rlist_set_rel"
  proof -
    have "(filter, op_set_filter) 
       (Id  bool_rel)  Idlist_set_rel  Idlist_set_rel"
      by (auto simp: list_set_rel_def br_def)
    note this[param_fo]
    moreover have "(filter,filter)(R  bool_rel)  Rlist_rel  Rlist_rel"
      unfolding List.filter_def
      by parametricity
    note this[param_fo]
    ultimately show ?thesis
      unfolding list_set_rel_def
      apply (intro fun_relI)
      apply (erule relcompE, simp)
      apply (rule relcompI)
      apply (rprems, assumption+)
      apply (rprems, simp+)
      done
  qed


  context begin interpretation autoref_syn .
  lemma list_set_autoref_inj_image[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes INJ: "SIDE_PRECOND_OPT (inj_on f s)"
    assumes [param]: "(fi,f)RaRb"
    assumes LP: "(l,s)Ralist_set_rel"
    shows "(map fi l, 
      (OP (`) ::: (RaRb)  Ralist_set_rel  Rblist_set_rel)$f$s) 
       Rblist_set_rel"
  proof -
    from LP obtain l' where 
      [param]: "(l,l')Ralist_rel" and L'S: "(l',s)br set distinct"
      unfolding list_set_rel_def by auto

    have "(map fi l, map f l')Rblist_rel" by parametricity
    also from INJ L'S have "(map f l',f`s)br set distinct"
      apply (induction l' arbitrary: s)
      apply (auto simp: br_def dest: injD)
      done
    finally (relcompI) show ?thesis 
      unfolding autoref_tag_defs list_set_rel_def .
  qed

  end


  lemma list_set_cart_autoref[autoref_rules]:
    fixes Rx :: "('xi × 'x) set"
    fixes Ry :: "('yi × 'y) set"
    shows "(λxl yl. [ (x,y). xxl, yyl], op_set_cart) 
     Rxlist_set_rel  Rylist_set_rel  Rx ×r Rylist_set_rel"
  proof (intro fun_relI)
    fix xl xs yl ys
    assume "(xl, xs)  Rxlist_set_rel" "(yl, ys)  Rylist_set_rel"
    then obtain xl' :: "'x list" and yl' :: "'y list" where 
      [param]: "(xl,xl')Rxlist_rel" "(yl,yl')Rylist_rel"
      and XLS: "(xl',xs)br set distinct" and YLS: "(yl',ys)br set distinct"
      unfolding list_set_rel_def 
      by auto

    have "([ (x,y). xxl, yyl ], [ (x,y). xxl', yyl' ]) 
       Rx ×r Rylist_rel"
      by parametricity
    also have "([ (x,y). xxl', yyl' ], xs × ys)  br set distinct"
      using XLS YLS
      apply (auto simp: br_def)
      apply hypsubst_thin
      apply (induction xl')
      apply simp
      apply (induction yl')
      apply simp
      apply auto []
      apply (metis (lifting) concat_map_maps distinct.simps(2) 
        distinct_singleton maps_simps(2))
      done
    finally (relcompI) 
    show "([ (x,y). xxl, yyl ], op_set_cart xs ys)  Rx ×r Rylist_set_rel"
      unfolding list_set_rel_def by simp
  qed


  subsection ‹Optimizations›
  lemma glist_delete_hd: "eq x y  glist_delete eq x (y#s) = s"
    by (simp add: glist_delete_def)

  text ‹Hack to ensure specific ordering. Note that ordering has no meaning
    abstractly›
  definition [simp]: "LIST_SET_REV_TAG  λx. x"
  
  lemma LIST_SET_REV_TAG_autoref[autoref_rules]: 
    "(rev,LIST_SET_REV_TAG)  Rlist_set_rel  Rlist_set_rel"
    unfolding list_set_rel_def
    apply (intro fun_relI)
    apply (elim relcompE)
    apply (clarsimp simp: br_def)
    apply (rule relcompI)
    apply (rule param_rev[param_fo], assumption)
    apply auto
    done
  
  



end

Theory Array_Iterator

theory Array_Iterator
imports Iterator "../Lib/Diff_Array"
begin

lemma idx_iteratei_aux_array_get_Array_conv_nth:
  "idx_iteratei_aux array_get sz i (Array xs) c f σ = 
   idx_iteratei_aux (!) sz i xs c f σ"
apply(induct get"(!) :: 'b list  nat  'b" sz i xs c f σ rule: idx_iteratei_aux.induct)
apply(subst (1 2) idx_iteratei_aux.simps)
apply simp
done

lemma idx_iteratei_array_get_Array_conv_nth:
  "idx_iteratei array_get array_length (Array xs) = idx_iteratei nth length xs"
by(simp add: idx_iteratei_def fun_eq_iff idx_iteratei_aux_array_get_Array_conv_nth)

end

Theory Impl_List_Map

section ‹\isaheader{List Based Maps}›
theory Impl_List_Map
imports
  "../../Iterator/Iterator"
  "../Gen/Gen_Map"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
begin

type_synonym ('k,'v) list_map = "('k×'v) list"

definition "list_map_invar = distinct o map fst"

definition list_map_rel_internal_def: 
    "list_map_rel Rk Rv  Rk,Rvprod_rellist_rel O br map_of list_map_invar"

lemma list_map_rel_def: 
    "Rk,Rvlist_map_rel = Rk,Rvprod_rellist_rel O br map_of list_map_invar"
    unfolding list_map_rel_internal_def[abs_def] by (simp add: relAPP_def)

lemma list_rel_Range:
    "x'set l'. x'  Range R  l'  Range (Rlist_rel)"
proof (induction l')
  case Nil thus ?case by force
next
  case (Cons x' xs')
    then obtain xs where "(xs,xs')  R list_rel" by force
    moreover from Cons.prems obtain x where "(x,x')  R" by force
    ultimately have "(x#xs, x'#xs')  R list_rel" by simp
    thus ?case ..
qed

text ‹All finite maps can be represented›
lemma list_map_rel_range:
  "Range (Rk,Rvlist_map_rel) = 
       {m. finite (dom m)  dom m  Range Rk  ran m  Range Rv}" 
       (is "?A = ?B")
proof (intro equalityI subsetI)
  fix m' assume "m'  ?A"
  then obtain l l' where A: "(l,l')  Rk,Rvprod_rellist_rel" and
                         B: "m' = map_of l'" and C: "list_map_invar l'"
       unfolding list_map_rel_def br_def by blast
  {
    fix x' y' assume "m' x' = Some y'"
    with B have "(x',y')  set l'" by (fast dest: map_of_SomeD)
    hence "x'  Range Rk" and "y'  Range Rv" 
      by (induction rule: list_rel_induct[OF A], auto)
  }
  with B show "m'  ?B" by (force dest: map_of_SomeD simp: ran_def)

next
  fix m' assume "m'  ?B"
  hence A: "finite (dom m')" and B: "dom m'  Range Rk" and 
        C: "ran m'  Range Rv" by simp_all
  from A have "finite (map_to_set m')" by (simp add: finite_map_to_set)
  from finite_distinct_list[OF this]
      obtain l' where l'_props: "distinct l'" "set l' = map_to_set m'" by blast
  hence *: "distinct (map fst l')"
      by (force simp: distinct_map inj_on_def map_to_set_def)
  from map_of_map_to_set[OF this] and l'_props 
      have  "map_of l' = m'" by simp
  with * have "(l',m')  br map_of list_map_invar"
      unfolding br_def list_map_invar_def o_def by simp

  moreover from B and C and l'_props 
      have "x  set l'. x  Range (Rk,Rvprod_rel)"
      unfolding map_to_set_def ran_def prod_rel_def by force
  from list_rel_Range[OF this] obtain l where 
      "(l,l')  Rk,Rvprod_rellist_rel" by force
  
  ultimately show "m'  ?A" unfolding list_map_rel_def by blast
qed


  lemmas [autoref_rel_intf] = REL_INTFI[of list_map_rel i_map]

  lemma list_map_rel_finite[autoref_ga_rules]:
    "finite_map_rel (Rk,Rvlist_map_rel)"
    unfolding finite_map_rel_def list_map_rel_def
    by (auto simp: br_def)

  lemma list_map_rel_sv[relator_props]:
    "single_valued Rk  single_valued Rv  
        single_valued (Rk,Rvlist_map_rel)"
    unfolding list_map_rel_def
    by tagged_solver
    
  (* TODO: Move to Misc *)


subsection ‹Implementation›

primrec list_map_lookup :: 
    "('k  'k  bool)  'k  ('k,'v) list_map  'v option" where
"list_map_lookup eq _ [] = None" |
"list_map_lookup eq k (y#ys) = 
     (if eq (fst y) k then Some (snd y) else list_map_lookup eq k ys)"


primrec list_map_update_aux :: "('k  'k  bool)  'k  'v  
    ('k,'v) list_map  ('k,'v) list_map  ('k,'v) list_map"where
"list_map_update_aux eq k v [] accu = (k,v) # accu" |
"list_map_update_aux eq k v (x#xs) accu = 
    (if eq (fst x) k
        then (k,v) # xs @ accu 
        else list_map_update_aux eq k v xs (x#accu))"

definition "list_map_update eq k v m  
    list_map_update_aux eq k v m []"

primrec list_map_delete_aux :: "('k  'k  bool)  'k  
    ('k, 'v) list_map  ('k, 'v) list_map  ('k, 'v) list_map" where
"list_map_delete_aux eq k [] accu = accu" |
"list_map_delete_aux eq k (x#xs) accu =
    (if eq (fst x) k
        then xs @ accu
        else list_map_delete_aux eq k xs (x#accu))"

definition "list_map_delete eq k m  list_map_delete_aux eq k m []"

definition list_map_isEmpty :: "('k,'v) list_map  bool"
    where "list_map_isEmpty  List.null"

definition list_map_isSng :: "('k,'v) list_map  bool"
    where "list_map_isSng m = (case m of [x]  True | _  False)"

definition list_map_size :: "('k,'v) list_map  nat"
    where "list_map_size  length"

definition list_map_iteratei :: "('k,'v) list_map  ('b  bool) 
    (('k×'v)  'b  'b)  'b  'b"
    where "list_map_iteratei  foldli"

definition list_map_to_list :: "('k,'v) list_map  ('k×'v) list"
    where "list_map_to_list = id"


subsection ‹Parametricity›

lemma list_map_autoref_empty[autoref_rules]:
  "([], op_map_empty)Rk,Rvlist_map_rel"
  by (auto simp: list_map_rel_def br_def list_map_invar_def)

lemma param_list_map_lookup[param]:
  "(list_map_lookup,list_map_lookup)  (Rk  Rk  bool_rel)  
       Rk  Rk,Rvprod_rellist_rel  Rvoption_rel"
unfolding list_map_lookup_def[abs_def] by parametricity

lemma list_map_autoref_lookup_aux:
  assumes eq: "GEN_OP eq (=) (RkRkId)"
  assumes K: "(k, k')  Rk"
  assumes M: "(m, m')  Rk, Rvprod_rellist_rel"
  shows "(list_map_lookup eq k m, op_map_lookup k' (map_of m'))
                Rvoption_rel"
unfolding op_map_lookup_def
proof (induction rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
    show ?case by simp
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,(=))  Rk  Rk  Id" by simp
    with eq'[param_fo] and K  and Cons 
        show ?case by (force simp: prod_rel_def)
qed

lemma list_map_autoref_lookup[autoref_rules]:
  assumes "GEN_OP eq (=) (RkRkId)"
  shows "(list_map_lookup eq, op_map_lookup)  
       Rk  Rk,Rvlist_map_rel  Rvoption_rel"
   by (force simp: list_map_rel_def br_def
             dest: list_map_autoref_lookup_aux[OF assms])



lemma param_list_map_update_aux[param]:
  "(list_map_update_aux,list_map_update_aux)  (Rk  Rk  bool_rel)  
       Rk  Rv  Rk,Rvprod_rellist_rel  Rk,Rvprod_rellist_rel
         Rk,Rvprod_rellist_rel"
unfolding list_map_update_aux_def[abs_def] by parametricity

lemma param_list_map_update[param]:
  "(list_map_update,list_map_update)  (Rk  Rk  bool_rel)  
       Rk  Rv  Rk,Rvprod_rellist_rel  Rk,Rvprod_rellist_rel"
unfolding list_map_update_def[abs_def] by parametricity


lemma list_map_autoref_update_aux1:
  assumes eq: "(eq,(=))  Rk  Rk  Id"
  assumes K: "(k, k')  Rk"
  assumes V: "(v, v')  Rv"
  assumes A: "(accu, accu')  Rk, Rvprod_rellist_rel"
  assumes M: "(m, m')  Rk, Rvprod_rellist_rel"
  shows "(list_map_update_aux eq k v m accu, 
          list_map_update_aux (=) k' v' m' accu')
                Rk, Rvprod_rellist_rel"
proof (insert A, induction arbitrary: accu accu' 
           rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil 
      thus ?case by (simp add: K V)
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,(=))  Rk  Rk  Id" by simp
    from eq'[param_fo] Cons(1) K 
        have [simp]: "(eq (fst x) k)  ((fst x') = k')" 
        by (force simp: prod_rel_def)
    show ?case
    proof (cases "eq (fst x) k")
      case False
        from Cons.prems and Cons.hyps have "(x # accu, x' # accu')  
            Rk, Rvprod_rellist_rel" by parametricity
        from Cons.IH[OF this] and False show ?thesis by simp
    next
      case True
        from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') 
            Rk, Rvprod_rellist_rel" by parametricity
        with K and V and True show ?thesis by simp
  qed
qed

lemma list_map_autoref_update1[param]:
  assumes eq: "(eq,(=))  Rk  Rk  Id"
  shows "(list_map_update eq, list_map_update (=))  Rk  Rv  
             Rk, Rvprod_rellist_rel  Rk, Rvprod_rellist_rel"
unfolding list_map_update_def[abs_def]
  by (intro fun_relI, erule (1) list_map_autoref_update_aux1[OF eq], 
      simp_all)


(* TODO: Move - Perhaps. *)
lemma map_add_sng_right: "m ++ [kv] = m(k  v)"
    unfolding map_add_def by force
lemma map_add_sng_right': 
    "m ++ (λa. if a = k then Some v else None) = m(k  v)"
    unfolding map_add_def by force

lemma list_map_autoref_update_aux2:
  assumes K: "(k, k')  Id"
  assumes V: "(v, v')  Id"
  assumes A: "(accu, accu')  br map_of list_map_invar"
  assumes A1: "distinct (map fst (m @ accu))"
  assumes A2: "k  set (map fst accu)"
  assumes M: "(m, m')  br map_of list_map_invar"
  shows "(list_map_update_aux (=) k v m accu, 
          accu' ++ op_map_update k' v' m')
                br map_of list_map_invar" (is "(?f m accu, _)  _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
  case Nil
    with K V show ?case by (auto simp: br_def list_map_invar_def 
        map_add_sng_right')
next
  case (Cons x xs accu accu' m')
    from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
        unfolding br_def by simp_all
    show ?case
    proof (cases "(fst x) =  k")
      case True
        hence "((k, v) # xs @ accu, accu' ++ op_map_update k' v' m')
                    br map_of list_map_invar"
            using K V Cons.prems(3,4) unfolding br_def
            by (force simp add: A list_map_invar_def)
        also from True have "(k,v) # xs @ accu = ?f (x # xs) accu" by simp
        finally show ?thesis .
    next
      case False
        from Cons.prems(1) have B: "(xs, map_of xs)  br map_of 
            list_map_invar"by (simp add: br_def list_map_invar_def)
        from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu))  br map_of
            list_map_invar" by (simp add: br_def list_map_invar_def)
        from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))" 
            by simp
        from Cons.prems(4) and False have E: "k  set (map fst (x # accu))"
            by simp
        note Cons.IH[OF B C D E]
        also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
        also from distinct_map_fstD[OF D] 
            have F: "z. (fst x, z)  set xs  z = snd x" by force
        have "map_of (x # accu) ++ op_map_update k' v' (map_of xs) = 
                  accu' ++ op_map_update k' v' m'"
            by (intro ext, auto simp: A F map_add_def 
                    dest: map_of_SomeD split: option.split)
        finally show ?thesis .
    qed
qed

lemma list_map_autoref_update2[param]:
  shows "(list_map_update (=), op_map_update)  Id  Id  
             br map_of list_map_invar  br map_of list_map_invar"
unfolding list_map_update_def[abs_def]
apply (intro fun_relI)
apply (drule list_map_autoref_update_aux2
                 [where accu="[]" and accu'="Map.empty"])
apply (auto simp: br_def list_map_invar_def)
done

lemma list_map_autoref_update[autoref_rules]:
  assumes eq: "GEN_OP eq (=) (RkRkId)"
  shows "(list_map_update eq, op_map_update) 
      Rk  Rv  Rk,Rvlist_map_rel  Rk,Rvlist_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (2) list_map_autoref_update1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_update2[param_fo], simp_all)
done

context begin interpretation autoref_syn .
lemma list_map_autoref_update_dj[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes new: "SIDE_PRECOND_OPT (k'  dom m')"
    assumes K: "(k,k')Rk" and V: "(v,v')Rv"
    assumes M: "(l,m')Rk, Rvlist_map_rel"
    defines "R_annot  Rk  Rv  Rk,Rvlist_map_rel  Rk,Rvlist_map_rel"
    shows "
      ((k, v)#l, 
        (OP op_map_update:::R_annot)$k'$v'$m')
       Rk,Rvlist_map_rel"
proof -
  from M obtain l' where A: "(l,l')  Rk, Rvprod_rellist_rel" and
      B: "(l',m')  br map_of list_map_invar"
      unfolding list_map_rel_def by blast
  hence "((k,v)#l, (k',v')#l')Rk, Rvprod_rellist_rel"
      and "((k',v')#l', m'(k'  v'))  br map_of list_map_invar"
      using assms unfolding br_def list_map_invar_def
          by (simp_all add: dom_map_of_conv_image_fst)
  thus ?thesis 
    unfolding autoref_tag_defs
    by (force simp: list_map_rel_def)
qed
end

lemma param_list_map_delete_aux[param]:
  "(list_map_delete_aux,list_map_delete_aux)  (Rk  Rk  bool_rel)  
       Rk  Rk,Rvprod_rellist_rel  Rk,Rvprod_rellist_rel
         Rk,Rvprod_rellist_rel"
unfolding list_map_delete_aux_def[abs_def] by parametricity

lemma param_list_map_delete[param]:
  "(list_map_delete,list_map_delete)  (Rk  Rk  bool_rel)  
       Rk  Rk,Rvprod_rellist_rel  Rk,Rvprod_rellist_rel"
unfolding list_map_delete_def[abs_def] by parametricity

lemma list_map_autoref_delete_aux1:
  assumes eq: "(eq,(=))  Rk  Rk  Id"
  assumes K: "(k, k')  Rk"
  assumes A: "(accu, accu')  Rk, Rvprod_rellist_rel"
  assumes M: "(m, m')  Rk, Rvprod_rellist_rel"
  shows "(list_map_delete_aux eq k m accu, 
          list_map_delete_aux (=) k' m' accu')
                Rk, Rvprod_rellist_rel"
proof (insert A, induction arbitrary: accu accu' 
           rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil 
      thus ?case by (simp add: K)
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,(=))  Rk  Rk  Id" by simp
    from eq'[param_fo] Cons(1) K 
        have [simp]: "(eq (fst x) k)  ((fst x') = k')" 
        by (force simp: prod_rel_def)
    show ?case
    proof (cases "eq (fst x) k")
      case False
        from Cons.prems and Cons.hyps have "(x # accu, x' # accu')  
            Rk, Rvprod_rellist_rel" by parametricity
        from Cons.IH[OF this] and False show ?thesis by simp
    next
      case True
        from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') 
            Rk, Rvprod_rellist_rel" by parametricity
        with K and True show ?thesis by simp
  qed
qed

lemma list_map_autoref_delete1[param]:
  assumes eq: "(eq,(=))  Rk  Rk  Id"
  shows "(list_map_delete eq, list_map_delete (=))  Rk  
             Rk, Rvprod_rellist_rel  Rk, Rvprod_rellist_rel"
unfolding list_map_delete_def[abs_def]
  by (intro fun_relI, erule list_map_autoref_delete_aux1[OF eq], 
      simp_all)


lemma list_map_autoref_delete_aux2:
  assumes K: "(k, k')  Id"
  assumes A: "(accu, accu')  br map_of list_map_invar"
  assumes A1: "distinct (map fst (m @ accu))"
  assumes A2: "k  set (map fst accu)"
  assumes M: "(m, m')  br map_of list_map_invar"
  shows "(list_map_delete_aux (=) k m accu, 
          accu' ++ op_map_delete k' m')
                br map_of list_map_invar" (is "(?f m accu, _)  _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
  case Nil
    with K show ?case by (auto simp: br_def list_map_invar_def 
        map_add_sng_right')
next
  case (Cons x xs accu accu' m')
    from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
        unfolding br_def by simp_all
    show ?case
    proof (cases "(fst x) =  k")
      case True
        with Cons.prems(3) have "map_of xs (fst x) = None" 
          by (induction xs, simp_all)
        with fun_upd_triv[of "map_of xs" "fst x"]
        have "map_of xs |` (- {fst x}) = map_of xs" 
          by (simp add: map_upd_eq_restrict)
        with True have"(xs @ accu, accu' ++ op_map_delete k' m')
                            br map_of list_map_invar"
            using K Cons.prems unfolding br_def
            by (auto simp add: A list_map_invar_def)
        thus ?thesis using True by simp
    next
      case False
        from False and K have [simp]: "fst x  k'" by simp
        from Cons.prems(1) have B: "(xs, map_of xs)  br map_of 
            list_map_invar"by (simp add: br_def list_map_invar_def)
        from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu))  br map_of
            list_map_invar" by (simp add: br_def list_map_invar_def)
        from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))" 
            by simp
        from Cons.prems(4) and False have E: "k  set (map fst (x # accu))"
            by simp
        note Cons.IH[OF B C D E]
        also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
        also from distinct_map_fstD[OF D] 
            have F: "z. (fst x, z)  set xs  z = snd x" by force

        from Cons.prems(3) have "map_of xs (fst x) = None"
            by (induction xs, simp_all)
        hence "map_of (x # accu) ++ op_map_delete k' (map_of xs) = 
               accu' ++ op_map_delete k' m'"
            apply (intro ext, simp add: map_add_def A
                                   split: option.split)
            apply (intro conjI impI allI)
            apply (auto simp: restrict_map_def)
            done
        finally show ?thesis .
    qed
qed

lemma list_map_autoref_delete2[param]:
  shows "(list_map_delete (=), op_map_delete)  Id  
             br map_of list_map_invar  br map_of list_map_invar"
unfolding list_map_delete_def[abs_def]
apply (intro fun_relI)
apply (drule list_map_autoref_delete_aux2
                 [where accu="[]" and accu'="Map.empty"])
apply (auto simp: br_def list_map_invar_def)
done

lemma list_map_autoref_delete[autoref_rules]:
  assumes eq: "GEN_OP eq (=) (RkRkId)"
  shows "(list_map_delete eq, op_map_delete) 
      Rk  Rk,Rvlist_map_rel  Rk,Rvlist_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (1) list_map_autoref_delete1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_delete2[param_fo], simp_all)
done

lemma list_map_autoref_isEmpty[autoref_rules]:
  shows "(list_map_isEmpty, op_map_isEmpty) 
             Rk,Rvlist_map_rel  bool_rel"
unfolding list_map_isEmpty_def op_map_isEmpty_def[abs_def]
    list_map_rel_def br_def List.null_def[abs_def] by force

lemma param_list_map_isSng[param]:
  assumes "(l,l')  Rk,Rvprod_rellist_rel"
  shows "(list_map_isSng l, list_map_isSng l')  bool_rel"
unfolding list_map_isSng_def using assms by parametricity

(* TODO: clean up this mess *)
lemma list_map_autoref_isSng_aux:
  assumes "(l',m')  br map_of list_map_invar"
  shows "(list_map_isSng l', op_map_isSng m')  bool_rel"
using assms 
unfolding list_map_isSng_def op_map_isSng_def br_def list_map_invar_def
apply (clarsimp split: list.split)
apply (intro conjI impI allI)
apply (metis map_upd_nonempty)
apply blast
apply (simp, metis fun_upd_apply option.distinct(1))
done

lemma list_map_autoref_isSng[autoref_rules]:
  "(list_map_isSng, op_map_isSng)  Rk,Rvlist_map_rel  bool_rel"
  unfolding list_map_rel_def
  by (blast dest!: param_list_map_isSng list_map_autoref_isSng_aux)

lemma list_map_autoref_size_aux:
  assumes "distinct (map fst x)"
  shows "card (dom (map_of x)) = length x"
proof-
  have "card (dom (map_of x)) = card (map_to_set (map_of x))"
      by (simp add: card_map_to_set)
  also from assms have "... = card (set x)" 
      by (simp add: map_to_set_map_of)
  also from assms have "... = length x" 
      by (force simp: distinct_card dest!: distinct_mapI)
  finally show ?thesis .
qed

lemma param_list_map_size[param]:
  "(list_map_size, list_map_size)  Rk,Rvprod_rellist_rel  nat_rel"
  unfolding list_map_size_def[abs_def] by parametricity

lemma list_map_autoref_size[autoref_rules]:
  shows "(list_map_size, op_map_size) 
             Rk,Rvlist_map_rel  nat_rel"
unfolding list_map_size_def[abs_def] op_map_size_def[abs_def]
    list_map_rel_def br_def list_map_invar_def
    by (force simp: list_map_autoref_size_aux list_rel_imp_same_length)


lemma autoref_list_map_is_iterator[autoref_ga_rules]: 
  shows "is_map_to_list Rk Rv list_map_rel list_map_to_list"
unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
  fix l m'
  assume "(l,m')  Rk,Rvlist_map_rel"
  then obtain l' where *: "(l,l')Rk,Rvprod_rellist_rel" "(l',m')br map_of list_map_invar" 
    unfolding list_map_rel_def by blast
  then have "RETURN l'  it_to_sorted_list (key_rel (λ_ _. True)) (map_to_set m')"
      unfolding it_to_sorted_list_def
      apply (intro refine_vcg)
      unfolding br_def list_map_invar_def key_rel_def[abs_def]
      apply (auto intro: distinct_mapI simp: map_to_set_map_of)
      done
  with * show
      "l'. (list_map_to_list l, l')  Rk, Rvprod_rellist_rel 
            RETURN l'  it_to_sorted_list (key_rel (λ_ _. True)) 
                             (map_to_set m')"
    unfolding list_map_to_list_def by force
qed

lemma pi_list_map[icf_proper_iteratorI]: 
  "proper_it (list_map_iteratei m) (list_map_iteratei m)"
unfolding proper_it_def list_map_iteratei_def by blast

lemma pi'_list_map[icf_proper_iteratorI]: 
  "proper_it' list_map_iteratei list_map_iteratei"
  by (rule proper_it'I, rule pi_list_map)


primrec list_map_pick_remove where
  "list_map_pick_remove [] = undefined"
| "list_map_pick_remove (kv#l) = (kv,l)"

context begin interpretation autoref_syn .
  lemma list_map_autoref_pick_remove[autoref_rules]:
    assumes NE: "SIDE_PRECOND (mMap.empty)"
    assumes R: "(l,m)Rk,Rvlist_map_rel"
    defines "Rres  (Rk×rRv) ×r Rk,Rvlist_map_relnres_rel"
    shows "(
        RETURN (list_map_pick_remove l),
        (OP op_map_pick_remove ::: Rk,Rvlist_map_rel  Rres)$m
      )  Rres"
  proof -
    from NE R obtain k v lr where 
      [simp]: "l=(k,v)#lr"
      by (cases l) (auto simp: list_map_rel_def br_def)
    
    thm list_map_rel_def
    from R obtain l' where 
      LL': "(l,l')Rk×rRvlist_rel" and 
      L'M: "(l',m)br map_of list_map_invar"
      unfolding list_map_rel_def by auto
    from LL' obtain k' v' lr' where
      [simp]: "l' = (k',v')#lr'" and 
        KVR: "(k,k')Rk" "(v,v')Rv" and
        LRR: "(lr,lr')Rk×rRvlist_rel"
      by (fastforce elim!: list_relE)
    
    from L'M have 
      MKV': "m k' = Some v'" and 
      LRR': "(lr',m|`(-{k'}))br map_of list_map_invar"
      by (auto 
        simp: restrict_map_def map_of_eq_None_iff br_def list_map_invar_def
        intro!: ext
        intro: sym)
      
    from LRR LRR' have LM: "(lr,m|`(-{k'}))Rk,Rvlist_map_rel"
      unfolding list_map_rel_def by auto

    show ?thesis
      apply (simp add: Rres_def)
      apply (refine_rcg SPEC_refine nres_relI refine_vcg)
      using LM KVR MKV'
      by auto
  qed
end

end

Theory Impl_Array_Hash_Map

section ‹\isaheader{Array Based Hash-Maps}›
theory Impl_Array_Hash_Map imports 
  Automatic_Refinement.Automatic_Refinement
  "../../Iterator/Array_Iterator"
  "../Gen/Gen_Map"
  "../Intf/Intf_Hash"
  "../Intf/Intf_Map"
  "../../Lib/HashCode"
  "../../Lib/Code_Target_ICF"
  "../../Lib/Diff_Array"
  Impl_List_Map
begin


subsection ‹Type definition and primitive operations›

definition load_factor :: nat ― ‹in percent›
  where "load_factor = 75"

datatype ('key, 'val) hashmap =
  HashMap "('key,'val) list_map array" "nat"

subsection ‹Operations›

definition new_hashmap_with :: "nat  ('k, 'v) hashmap"
where "size. new_hashmap_with size = 
    HashMap (new_array [] size) 0"

definition ahm_empty :: "nat  ('k, 'v) hashmap"
where "ahm_empty def_size  new_hashmap_with def_size"

definition bucket_ok :: "'k bhc  nat  nat  ('k×'v) list  bool"
where "bucket_ok bhc len h kvs = (k  fst ` set kvs. bhc len k = h)"

definition ahm_invar_aux :: "'k bhc  nat  ('k×'v) list array  bool"
where
  "ahm_invar_aux bhc n a 
  (h. h < array_length a  bucket_ok bhc (array_length a) h 
      (array_get a h)  list_map_invar (array_get a h)) 
  array_foldl (λ_ n kvs. n + size kvs) 0 a = n 
  array_length a > 1"

primrec ahm_invar :: "'k bhc  ('k, 'v) hashmap  bool"
where "ahm_invar bhc (HashMap a n) = ahm_invar_aux bhc n a"

definition ahm_lookup_aux :: "'k eq  'k bhc 
    'k  ('k, 'v) list_map array  'v option"
where [simp]: "ahm_lookup_aux eq bhc k a  = list_map_lookup eq k (array_get a (bhc (array_length a) k))"

primrec ahm_lookup where
"ahm_lookup eq bhc k (HashMap a _) = ahm_lookup_aux eq bhc k a"

definition "ahm_α bhc m  λk. ahm_lookup (=) bhc k m"

definition ahm_map_rel_def_internal: 
    "ahm_map_rel Rk Rv  {(HashMap a n, HashMap a' n)| a a' n n'.
         (a,a')  Rk,Rvprod_rellist_relarray_rel  (n,n')  Id}"

lemma ahm_map_rel_def: "Rk,Rv ahm_map_rel  
{(HashMap a n, HashMap a' n)| a a' n n'.
         (a,a')  Rk,Rvprod_rellist_relarray_rel  (n,n')  Id}"
    unfolding relAPP_def ahm_map_rel_def_internal .

definition ahm_map_rel'_def: 
  "ahm_map_rel' bhc  br (ahm_α bhc) (ahm_invar bhc)"

definition ahm_rel_def_internal: "ahm_rel bhc Rk Rv = 
    Rk,Rv ahm_map_rel O ahm_map_rel' (abstract_bounded_hashcode Rk bhc)"
lemma ahm_rel_def: "Rk, Rv ahm_rel bhc 
     Rk,Rv ahm_map_rel O ahm_map_rel' (abstract_bounded_hashcode Rk bhc)" 
    unfolding relAPP_def ahm_rel_def_internal .
lemmas [autoref_rel_intf] = REL_INTFI[of "ahm_rel bhc" i_map] for bhc

abbreviation "dflt_ahm_rel  ahm_rel bounded_hashcode_nat"


primrec ahm_iteratei_aux :: "(('k×'v) list array)  ('k×'v, ) set_iterator"
where "ahm_iteratei_aux (Array xs) c f = foldli (concat xs) c f"

primrec ahm_iteratei :: "(('k, 'v) hashmap)  (('k×'v), ) set_iterator"
where
  "ahm_iteratei (HashMap a n) = ahm_iteratei_aux a"

definition ahm_rehash_aux' :: "'k bhc  nat  'k×'v  
    ('k×'v) list array  ('k×'v) list array"
where
  "ahm_rehash_aux' bhc n kv a =
   (let h = bhc n (fst kv)
    in array_set a h (kv # array_get a h))"

definition ahm_rehash_aux :: "'k bhc  ('k×'v) list array  nat  
    ('k×'v) list array"
where
  "ahm_rehash_aux bhc a sz = ahm_iteratei_aux a (λx. True) 
       (ahm_rehash_aux' bhc sz) (new_array [] sz)"

primrec ahm_rehash :: "'k bhc  ('k,'v) hashmap  nat  ('k,'v) hashmap"
where "ahm_rehash bhc (HashMap a n) sz = HashMap (ahm_rehash_aux bhc a sz) n"

primrec hm_grow :: "('k,'v) hashmap  nat"
where "hm_grow (HashMap a n) = 2 * array_length a + 3"

primrec ahm_filled :: "('k,'v) hashmap  bool"
where "ahm_filled (HashMap a n) = (array_length a * load_factor  n * 100)"

primrec ahm_update_aux :: "'k eq  'k bhc  ('k,'v) hashmap  
    'k  'v  ('k, 'v) hashmap"
where
  "ahm_update_aux eq bhc (HashMap a n) k v = 
  (let h = bhc (array_length a) k;
       m = array_get a h;
       insert = list_map_lookup eq k m = None
   in HashMap (array_set a h (list_map_update eq k v m)) 
       (if insert then n + 1 else n))"

definition ahm_update :: "'k eq  'k bhc  'k  'v  
    ('k, 'v) hashmap  ('k, 'v) hashmap"
where
  "ahm_update eq bhc k v hm = 
   (let hm' = ahm_update_aux eq bhc hm k v
    in (if ahm_filled hm' then ahm_rehash bhc hm' (hm_grow hm') else hm'))"

primrec ahm_delete :: "'k eq  'k bhc  'k  
    ('k,'v) hashmap  ('k,'v) hashmap"
where
  "ahm_delete eq bhc k (HashMap a n) =
  (let h = bhc (array_length a) k;
       m = array_get a h;
       deleted = (list_map_lookup eq k m  None)
   in HashMap (array_set a h (list_map_delete eq k m)) (if deleted then n - 1 else n))"

primrec ahm_isEmpty :: "('k,'v) hashmap  bool" where
  "ahm_isEmpty (HashMap _ n) = (n = 0)"

primrec ahm_isSng :: "('k,'v) hashmap  bool" where
  "ahm_isSng (HashMap _ n) = (n = 1)"

primrec ahm_size :: "('k,'v) hashmap  nat" where
  "ahm_size (HashMap _ n) = n"


lemma hm_grow_gt_1 [iff]:
  "Suc 0 < hm_grow hm"
by(cases hm)(simp)

lemma bucket_ok_Nil [simp]: "bucket_ok bhc len h [] = True"
by(simp add: bucket_ok_def)

lemma bucket_okD:
  " bucket_ok bhc len h xs; (k, v)  set xs 
   bhc len k = h"
by(auto simp add: bucket_ok_def)

lemma bucket_okI:
  "(k. k  fst ` set kvs  bhc len k = h)  bucket_ok bhc len h kvs"
by(simp add: bucket_ok_def)


subsection ‹Parametricity›

lemma param_HashMap[param]: "(HashMap, HashMap)  
    Rk,Rvprod_rellist_relarray_rel  nat_rel  Rk,Rvahm_map_rel" 
    unfolding ahm_map_rel_def by force

lemma param_case_hashmap[param]: "(case_hashmap, case_hashmap) 
    (Rk,Rvprod_rellist_relarray_rel  nat_rel  R)  
     Rk,Rvahm_map_rel  R"
unfolding ahm_map_rel_def[abs_def]
by (force split: hashmap.split dest: fun_relD)

lemma rec_hashmap_is_case[simp]: "rec_hashmap = case_hashmap"
  by (intro ext, simp split: hashmap.split)



subsection @{term ahm_invar}

lemma ahm_invar_auxD:
  assumes "ahm_invar_aux bhc n a"
  shows "h. h < array_length a  
            bucket_ok bhc (array_length a) h (array_get a h)" and
        "h. h < array_length a  
            list_map_invar (array_get a h)" and
        "n = array_foldl (λ_ n kvs. n + length kvs) 0 a" and 
        "array_length a > 1"
using assms unfolding ahm_invar_aux_def by auto

lemma ahm_invar_auxE:
  assumes "ahm_invar_aux bhc n a"
  obtains "h. h < array_length a  
      bucket_ok bhc (array_length a) h (array_get a h)  
      list_map_invar (array_get a h)" and
  "n = array_foldl (λ_ n kvs. n + length kvs) 0 a" and 
  "array_length a > 1"
using assms unfolding ahm_invar_aux_def by blast

lemma ahm_invar_auxI:
  " h. h < array_length a  
         bucket_ok bhc (array_length a) h (array_get a h);
     h. h < array_length a  list_map_invar (array_get a h);
     n = array_foldl (λ_ n kvs. n + length kvs) 0 a; array_length a > 1 
   ahm_invar_aux bhc n a"
unfolding ahm_invar_aux_def by blast

lemma ahm_invar_distinct_fst_concatD:
  assumes inv: "ahm_invar_aux bhc n (Array xs)"
  shows "distinct (map fst (concat xs))"
proof -
  { fix h
    assume "h < length xs"
    with inv have "bucket_ok bhc (length xs) h (xs ! h)" and 
                  "list_map_invar (xs ! h)"
      by(simp_all add: ahm_invar_aux_def) }
  note no_junk = this

  show ?thesis unfolding map_concat
  proof(rule distinct_concat')
    have "distinct [xxs . x  []]" unfolding distinct_conv_nth
    proof(intro allI ballI impI)
      fix i j
      assume "i < length [xxs . x  []]" "j < length [xxs . x  []]" "i  j"
      from filter_nth_ex_nth[OF i < length [xxs . x  []]]
      obtain i' where "i'  i" "i' < length xs" and ith: "[xxs . x  []] ! i = xs ! i'" 
        and eqi: "[xtake i' xs . x  []] = take i [xxs . x  []]" by blast
      from filter_nth_ex_nth[OF j < length [xxs . x  []]]
      obtain j' where "j'  j" "j' < length xs" and jth: "[xxs . x  []] ! j = xs ! j'"
        and eqj: "[xtake j' xs . x  []] = take j [xxs . x  []]" by blast
      show "[xxs . x  []] ! i  [xxs . x  []] ! j"
      proof
        assume "[xxs . x  []] ! i = [xxs . x  []] ! j"
        hence eq: "xs ! i' = xs ! j'" using ith jth by simp
        from i < length [xxs . x  []]
        have "[xxs . x  []] ! i  set [xxs . x  []]" by(rule nth_mem)
        with ith have "xs ! i'  []" by simp
        then obtain kv where "kv  set (xs ! i')" by(fastforce simp add: neq_Nil_conv)
        with no_junk[OF i' < length xs] have "bhc (length xs) (fst kv) = i'"
          by(simp add: bucket_ok_def)
        moreover from eq kv  set (xs ! i') have "kv  set (xs ! j')" by simp
        with no_junk[OF j' < length xs] have "bhc (length xs) (fst kv) = j'"
          by(simp add: bucket_ok_def)
        ultimately have [simp]: "i' = j'" by simp
        from i < length [xxs . x  []] have "i = length (take i [xxs . x  []])" by simp
        also from eqi eqj have "take i [xxs . x  []] = take j [xxs . x  []]" by simp
        finally show False using i  j j < length [xxs . x  []] by simp
      qed
    qed
    moreover have "inj_on (map fst) {x  set xs. x  []}"
    proof(rule inj_onI)
      fix x y
      assume "x  {x  set xs. x  []}" "y  {x  set xs. x  []}" "map fst x = map fst y"
      hence "x  set xs" "y  set xs" "x  []" "y  []" by auto
      from x  set xs obtain i where "xs ! i = x" "i < length xs" unfolding set_conv_nth by fastforce
      from y  set xs obtain j where "xs ! j = y" "j < length xs" unfolding set_conv_nth by fastforce
      from x  [] obtain k v x' where "x = (k, v) # x'" by(cases x) auto
      with no_junk[OF i < length xs] xs ! i = x
      have "bhc (length xs) k = i" by(auto simp add: bucket_ok_def)
      moreover from ‹map fst x = map fst y x = (k, v) # x' obtain v' where "(k, v')  set y" by fastforce
      with no_junk[OF j < length xs] xs ! j = y
      have "bhc (length xs) k = j" by(auto simp add: bucket_ok_def)
      ultimately have "i = j" by simp
      with xs ! i = x xs ! j = y show "x = y" by simp
    qed
    ultimately show "distinct [ysmap (map fst) xs . ys  []]"
      by(simp add: filter_map o_def distinct_map)
  next
    fix ys
    have A: "xs. distinct (map fst xs) = list_map_invar xs"
        by (simp add: list_map_invar_def)
    assume "ys  set (map (map fst) xs)"
    thus "distinct ys"
        by(clarsimp simp add: set_conv_nth A) (erule no_junk(2))
  next
    fix ys zs
    assume "ys  set (map (map fst) xs)" "zs  set (map (map fst) xs)" "ys  zs"
    then obtain ys' zs' where [simp]: "ys = map fst ys'" "zs = map fst zs'" 
      and "ys'  set xs" "zs'  set xs" by auto
    have "fst ` set ys'  fst ` set zs' = {}"
    proof(rule equals0I)
      fix k
      assume "k  fst ` set ys'  fst ` set zs'"
      then obtain v v' where "(k, v)  set ys'" "(k, v')  set zs'" by(auto)
      from ys'  set xs obtain i where "xs ! i = ys'" "i < length xs" unfolding set_conv_nth by fastforce
      with (k, v)  set ys' have "bhc (length xs) k = i" by(auto dest: no_junk bucket_okD)
      moreover
      from zs'  set xs obtain j where "xs ! j = zs'" "j < length xs" unfolding set_conv_nth by fastforce
      with (k, v')  set zs' have "bhc (length xs) k = j" by(auto dest: no_junk bucket_okD)
      ultimately have "i = j" by simp
      with xs ! i = ys' xs ! j = zs' have "ys' = zs'" by simp
      with ys  zs show False by simp
    qed
    thus "set ys  set zs = {}" by simp
  qed
qed

subsection @{term "ahm_α"}

(* TODO: Move this *)
lemma list_map_lookup_is_map_of:
     "list_map_lookup (=) k l = map_of l k"
      using list_map_autoref_lookup_aux[where eq="(=)" and
           Rk=Id and Rv=Id] by force
definition "ahm_α_aux bhc a  
    (λk. ahm_lookup_aux (=) bhc k a)"
lemma ahm_α_aux_def2: "ahm_α_aux bhc a = (λk. map_of (array_get a 
    (bhc (array_length a) k)) k)"
    unfolding ahm_α_aux_def ahm_lookup_aux_def
    by (simp add: list_map_lookup_is_map_of)
lemma ahm_α_def2: "ahm_α bhc (HashMap a n) = ahm_α_aux bhc a"
    unfolding ahm_α_def ahm_α_aux_def by simp

lemma finite_dom_ahm_α_aux:
  assumes "is_bounded_hashcode Id (=) bhc" "ahm_invar_aux bhc n a"
  shows "finite (dom (ahm_α_aux bhc a))"
proof -
  have "dom (ahm_α_aux bhc a)  (h  range (bhc (array_length a) :: 'a  nat). dom (map_of (array_get a h)))" 
    unfolding ahm_α_aux_def2
    by(force simp add: dom_map_of_conv_image_fst dest: map_of_SomeD)
  moreover have "finite "
  proof(rule finite_UN_I)
    from ‹ahm_invar_aux bhc n a have "array_length a > 1" by(simp add: ahm_invar_aux_def)
    hence "range (bhc (array_length a) :: 'a  nat)  {0..<array_length a}"
      using assms by force
    thus "finite (range (bhc (array_length a) :: 'a  nat))"
      by(rule finite_subset) simp
  qed(rule finite_dom_map_of)
  ultimately show ?thesis by(rule finite_subset)
qed

lemma ahm_α_aux_new_array[simp]:
  assumes bhc: "is_bounded_hashcode Id (=) bhc" "1 < sz"
  shows "ahm_α_aux bhc (new_array [] sz) k = None"
  using is_bounded_hashcodeD(3)[OF assms]
  unfolding ahm_α_aux_def ahm_lookup_aux_def by simp

lemma ahm_α_aux_conv_map_of_concat:
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  assumes inv: "ahm_invar_aux bhc n (Array xs)"
  shows "ahm_α_aux bhc (Array xs) = map_of (concat xs)"
proof
  fix k
  show "ahm_α_aux bhc (Array xs) k = map_of (concat xs) k"
  proof(cases "map_of (concat xs) k")
    case None
    hence "k  fst ` set (concat xs)" by(simp add: map_of_eq_None_iff)
    hence "k  fst ` set (xs ! bhc (length xs) k)"
    proof(rule contrapos_nn)
      assume "k  fst ` set (xs ! bhc (length xs) k)"
      then obtain v where "(k, v)  set (xs ! bhc (length xs) k)" by auto
      moreover from inv have "bhc (length xs) k < length xs"
        using bhc by (force simp: ahm_invar_aux_def)
      ultimately show "k  fst ` set (concat xs)"
        by (force intro: rev_image_eqI)
    qed
    thus ?thesis unfolding None ahm_α_aux_def2
        by (simp add: map_of_eq_None_iff)
  next
    case (Some v)
    hence "(k, v)  set (concat xs)" by(rule map_of_SomeD)
    then obtain ys where "ys  set xs" "(k, v)  set ys"
      unfolding set_concat by blast
    from ys  set xs obtain i j where "i < length xs" "xs ! i = ys"
      unfolding set_conv_nth by auto
    with inv (k, v)  set ys
    show ?thesis unfolding Some
      unfolding ahm_α_aux_def2
      by(force dest: bucket_okD simp add: ahm_invar_aux_def list_map_invar_def)
  qed
qed

lemma ahm_invar_aux_card_dom_ahm_α_auxD:
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  assumes inv: "ahm_invar_aux bhc n a"
  shows "card (dom (ahm_α_aux bhc a)) = n"
proof(cases a)
  case [simp]: (Array xs)
  from inv have "card (dom (ahm_α_aux bhc (Array xs))) = card (dom (map_of (concat xs)))"
    by(simp add: ahm_α_aux_conv_map_of_concat[OF bhc])
  also from inv have "distinct (map fst (concat xs))"
    by(simp add: ahm_invar_distinct_fst_concatD)
  hence "card (dom (map_of (concat xs))) = length (concat xs)"
    by(rule card_dom_map_of)
  also have "length (concat xs) = foldl (+) 0 (map length xs)"
    by (simp add: length_concat foldl_conv_fold add.commute fold_plus_sum_list_rev)
  also from inv
  have " = n" unfolding foldl_map by(simp add: ahm_invar_aux_def array_foldl_foldl)
  finally show ?thesis by(simp)
qed

lemma finite_dom_ahm_α:
  assumes "is_bounded_hashcode Id (=) bhc" "ahm_invar bhc hm"
  shows "finite (dom (ahm_α bhc hm))"
  using assms by (cases hm, force intro: finite_dom_ahm_α_aux 
      simp: ahm_α_def2)


subsection @{term ahm_empty}

lemma ahm_invar_aux_new_array:
  assumes "n > 1"
  shows "ahm_invar_aux bhc 0 (new_array [] n)"
proof -
  have "foldl (λb (k, v). b + length v) 0 (zip [0..<n] (replicate n [])) = 0"
    by(induct n)(simp_all add: replicate_Suc_conv_snoc del: replicate_Suc)
  with assms show ?thesis by(simp add: ahm_invar_aux_def array_foldl_new_array list_map_invar_def)
qed

lemma ahm_invar_new_hashmap_with:
  "n > 1  ahm_invar bhc (new_hashmap_with n)"
by(auto simp add: ahm_invar_def new_hashmap_with_def intro: ahm_invar_aux_new_array)

lemma ahm_α_new_hashmap_with:
  assumes "is_bounded_hashcode Id (=) bhc" and "n > 1"
  shows "Map.empty = ahm_α bhc (new_hashmap_with n)"
  unfolding new_hashmap_with_def ahm_α_def
  using is_bounded_hashcodeD(3)[OF assms] by force

lemma ahm_empty_impl:
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  assumes def_size: "def_size > 1"
  shows "(ahm_empty def_size, Map.empty)  ahm_map_rel' bhc"
proof-
  from def_size and ahm_α_new_hashmap_with[OF bhc def_size] and
       ahm_invar_new_hashmap_with[OF def_size]
  show ?thesis unfolding ahm_empty_def ahm_map_rel'_def br_def by force
qed

lemma param_ahm_empty[param]: 
  assumes def_size: "(def_size, def_size')  nat_rel"
  shows "(ahm_empty def_size ,ahm_empty def_size')  
      Rk,Rvahm_map_rel"
unfolding ahm_empty_def[abs_def] new_hashmap_with_def[abs_def]
    new_array_def[abs_def]
using assms by parametricity

lemma autoref_ahm_empty[autoref_rules]:
  fixes Rk :: "('kc×'ka) set"
  assumes bhc: "SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
  assumes def_size: "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('kc) def_size)"
  shows "(ahm_empty def_size, op_map_empty)  Rk, Rvahm_rel bhc"
proof-
  from bhc have eq': "(eq,(=))  Rk  Rk  bool_rel" 
    by (simp add: is_bounded_hashcodeD)
  with bhc have "is_bounded_hashcode Id (=) 
      (abstract_bounded_hashcode Rk bhc)" 
    unfolding autoref_tag_defs
    by blast
  thus ?thesis using assms 
    unfolding op_map_empty_def
    unfolding ahm_rel_def is_valid_def_hm_size_def autoref_tag_defs
    apply (intro relcompI)
    apply (rule param_ahm_empty[of def_size def_size], simp)
    apply (blast intro: ahm_empty_impl)
    done
qed


subsection @{term "ahm_lookup"}

lemma param_ahm_lookup[param]:
  assumes bhc: "is_bounded_hashcode Rk eq bhc"
  defines bhc'_def: "bhc'  abstract_bounded_hashcode Rk bhc"
  assumes inv: "ahm_invar bhc' m'"
  assumes K: "(k,k')  Rk"
  assumes M: "(m,m')  Rk,Rvahm_map_rel"
  shows "(ahm_lookup eq bhc k m, ahm_lookup (=) bhc' k' m')  
             Rvoption_rel"
proof-
  from bhc have eq': "(eq,(=))  Rk  Rk  bool_rel" by (simp add: is_bounded_hashcodeD)
  moreover from abstract_bhc_correct[OF bhc] 
      have bhc': "(bhc,bhc')  nat_rel  Rk  nat_rel" unfolding bhc'_def .
  moreover from M obtain a a' n n' where 
      [simp]: "m = HashMap a n" and [simp]: "m' = HashMap a' n'" and
      A: "(a,a')  Rk,Rvprod_rellist_relarray_rel" and N: "(n,n')  Id"
          by (cases m, cases m', unfold ahm_map_rel_def, auto)
  moreover from inv and array_rel_imp_same_length[OF A]
      have "array_length a > 1" by (simp add: ahm_invar_aux_def)
  with abstract_bhc_is_bhc[OF bhc]
      have "bhc' (array_length a) k' < array_length a"
      unfolding bhc'_def by blast
  with bhc'[param_fo, OF _ K] 
      have "bhc (array_length a) k < array_length a" by simp
  ultimately show ?thesis using K
      unfolding ahm_lookup_def[abs_def] rec_hashmap_is_case
      by (simp, parametricity)
qed


lemma ahm_lookup_impl:
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  shows "(ahm_lookup (=) bhc, op_map_lookup)  Id  ahm_map_rel' bhc  Id"
unfolding ahm_map_rel'_def br_def ahm_α_def by force

lemma autoref_ahm_lookup[autoref_rules]:
  assumes 
    bhc[unfolded autoref_tag_defs]: "SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
  shows "(ahm_lookup eq bhc, op_map_lookup) 
     Rk  Rk,Rvahm_rel bhc  Rvoption_rel"
proof (intro fun_relI)
  let ?bhc' = "abstract_bounded_hashcode Rk bhc"
  fix k k' a m'
  assume K: "(k,k')  Rk"
  assume M: "(a,m')  Rk,Rvahm_rel bhc"
  from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'" 
    by blast

  from M obtain a' where M1: "(a,a')  Rk,Rvahm_map_rel" and
      M2: "(a',m')  ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
  hence inv: "ahm_invar ?bhc' a'" 
      unfolding ahm_map_rel'_def br_def by simp
  
  from relcompI[OF param_ahm_lookup[OF bhc inv K M1]
                   ahm_lookup_impl[param_fo, OF bhc' _ M2]]
  show "(ahm_lookup eq bhc k a, op_map_lookup k' m')  Rvoption_rel"
      by simp
qed


subsection @{term "ahm_iteratei"}

abbreviation "ahm_to_list  it_to_list ahm_iteratei"

lemma param_ahm_iteratei_aux[param]:
  "(ahm_iteratei_aux,ahm_iteratei_aux)  Ralist_relarray_rel 
       (Rb  bool_rel)  (Ra  Rb  Rb)  Rb  Rb"
unfolding ahm_iteratei_aux_def[abs_def] by parametricity

lemma param_ahm_iteratei[param]:
  "(ahm_iteratei,ahm_iteratei)  Rk,Rvahm_map_rel 
       (Rb  bool_rel)  (Rk,Rvprod_rel  Rb  Rb)  Rb  Rb"
unfolding ahm_iteratei_def[abs_def] rec_hashmap_is_case by parametricity

lemma param_ahm_to_list[param]:
  "(ahm_to_list,ahm_to_list)  
       Rk, Rvahm_map_rel  Rk,Rvprod_rellist_rel"
unfolding it_to_list_def[abs_def] by parametricity

lemma ahm_to_list_distinct[simp,intro]:
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  assumes inv: "ahm_invar bhc m"
  shows "distinct (ahm_to_list m)"
proof-
  obtain n a where [simp]: "m = HashMap a n" by (cases m)
  obtain l where [simp]: "a = Array l" by (cases a)
  from inv show "distinct (ahm_to_list m)" unfolding it_to_list_def
      by (force intro: distinct_mapI dest: ahm_invar_distinct_fst_concatD)
qed



lemma set_ahm_to_list:
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  assumes ref: "(m,m')  ahm_map_rel' bhc"
  shows "map_to_set m' = set (ahm_to_list m)"
proof-
  obtain n a where [simp]: "m = HashMap a n" by (cases m)
  obtain l where [simp]: "a = Array l" by (cases a)
  from ref have α[simp]: "m' = ahm_α bhc m" and 
      inv: "ahm_invar bhc m"
      unfolding ahm_map_rel'_def br_def by auto
  
  from inv have length: "length l > 1" 
      unfolding ahm_invar_def ahm_invar_aux_def by force
  from inv have buckets_ok: "h x. h < length l  x  set (l!h) 
      bhc (length l) (fst x) = h"
      "h. h < length l   distinct (map fst (l!h))"
      by (simp_all add: ahm_invar_def ahm_invar_aux_def 
                        bucket_ok_def list_map_invar_def)

  show ?thesis unfolding it_to_list_def α ahm_α_def ahm_iteratei_def
      apply (simp add: list_map_lookup_is_map_of)
  proof (intro equalityI subsetI, goal_cases)
    case prems: (1 x)
    let ?m = "λk. map_of (l ! bhc (length l) k) k"
    obtain k v where [simp]: "x = (k, v)" by (cases x)
    from prems have "set_to_map (map_to_set ?m) k = Some v"
      by (simp add: set_to_map_simp inj_on_fst_map_to_set)
    also note map_to_set_inverse
    finally have "map_of (l ! bhc (length l) k) k = Some v" .
    hence "(k,v)  set (l ! bhc (length l) k)"
      by (simp add: map_of_SomeD)
    moreover have "bhc (length l) k < length l" using bhc length ..
    ultimately show ?case by force
  next
    case prems: (2 x)
    obtain k v where [simp]: "x = (k, v)" by (cases x)
    from prems obtain h where h_props: "(k,v)  set (l!h)" "h < length l"
      by (force simp: set_conv_nth)
    moreover from h_props and buckets_ok
    have "bhc (length l) k = h" "distinct (map fst (l!h))" by auto
    ultimately have "map_of (l ! bhc (length l) k) k = Some v"
      by (force intro: map_of_is_SomeI)
    thus ?case by simp
  qed
qed

(* TODO: find out what the problem is here *)

lemma ahm_iteratei_aux_impl:
  assumes inv: "ahm_invar_aux bhc n a"
  and bhc: "is_bounded_hashcode Id (=) bhc"
  shows "map_iterator (ahm_iteratei_aux a) (ahm_α_aux bhc a)"
proof (cases a, rule)
  fix xs assume [simp]: "a = Array xs"
  show "ahm_iteratei_aux a = foldli (concat xs)"
      by (intro ext, simp)
  from ahm_invar_distinct_fst_concatD and inv
      show "distinct (map fst (concat xs))" by simp
  from ahm_α_aux_conv_map_of_concat and assms
      show "ahm_α_aux bhc a = map_of (concat xs)" by simp
qed

lemma ahm_iteratei_impl:
  assumes inv: "ahm_invar bhc m"
  and bhc: "is_bounded_hashcode Id (=) bhc"
  shows "map_iterator (ahm_iteratei m) (ahm_α bhc m)"
  by (insert assms, cases m, simp add: ahm_α_def2,
          erule (1) ahm_iteratei_aux_impl)

lemma autoref_ahm_is_iterator[autoref_ga_rules]:
  (*assumes eq: "GEN_OP_tag ((eq,OP (=) ::: (Rk → Rk → bool_rel)) ∈ (Rk → Rk → bool_rel))"*)
  assumes bhc: "GEN_ALGO_tag (is_bounded_hashcode Rk eq bhc)"
  shows "is_map_to_list Rk Rv (ahm_rel bhc) ahm_to_list"
  unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (intro allI impI)
  let ?bhc' = "abstract_bounded_hashcode Rk bhc"
  fix a m' assume M: "(a,m')  Rk,Rvahm_rel bhc"
  from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'" 
    unfolding autoref_tag_defs
    apply (rule_tac abstract_bhc_is_bhc)
    by simp_all

  from M obtain a' where M1: "(a,a')  Rk,Rvahm_map_rel" and
      M2: "(a',m')  ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
  hence inv: "ahm_invar ?bhc' a'" 
      unfolding ahm_map_rel'_def br_def by simp

  let ?l' = "ahm_to_list a'"
  from param_ahm_to_list[param_fo, OF M1]
      have "(ahm_to_list a, ?l')  Rk,Rvprod_rellist_rel" .
  moreover from ahm_to_list_distinct[OF bhc' inv] 
      have "distinct (ahm_to_list a')" .
  moreover from set_ahm_to_list[OF bhc' M2]
      have "map_to_set m' = set (ahm_to_list a')" .
  ultimately show "l'. (ahm_to_list a, l')  Rk,Rvprod_rellist_rel 
                        RETURN l'  it_to_sorted_list 
                            (key_rel (λ_ _. True)) (map_to_set m')"
      by (force simp: it_to_sorted_list_def key_rel_def[abs_def])
qed


lemma ahm_iteratei_aux_code[code]:
  "ahm_iteratei_aux a c f σ = idx_iteratei array_get array_length a c 
       (λx. foldli x c f) σ"
proof(cases a)
  case [simp]: (Array xs)
  have "ahm_iteratei_aux a c f σ = foldli (concat xs) c f σ" by simp
  also have " = foldli xs c (λx. foldli x c f) σ" by (simp add: foldli_concat)
  also have " = idx_iteratei (!) length xs c (λx. foldli x c f) σ" 
      by (simp add: idx_iteratei_nth_length_conv_foldli)
  also have " = idx_iteratei array_get array_length a c (λx. foldli x c f) σ"
    by(simp add: idx_iteratei_array_get_Array_conv_nth)
  finally show ?thesis .
qed


subsection @{term "ahm_rehash"}

lemma array_length_ahm_rehash_aux':
  "array_length (ahm_rehash_aux' bhc n kv a) = array_length a"
by(simp add: ahm_rehash_aux'_def Let_def)

lemma ahm_rehash_aux'_preserves_ahm_invar_aux:
  assumes inv: "ahm_invar_aux bhc n a"
  and bhc: "is_bounded_hashcode Id (=) bhc"
  and fresh: "k  fst ` set (array_get a (bhc (array_length a) k))"
  shows "ahm_invar_aux bhc (Suc n) (ahm_rehash_aux' bhc (array_length a) (k, v) a)"
  (is "ahm_invar_aux bhc _ ?a")
proof(rule ahm_invar_auxI)
  note invD = ahm_invar_auxD[OF inv]
  let ?l = "array_length a"
  fix h
  assume "h < array_length ?a"
  hence hlen: "h < ?l" by(simp add: array_length_ahm_rehash_aux')
  from invD(1,2)[OF this] have bucket: "bucket_ok bhc ?l h (array_get a h)"
    and dist: "distinct (map fst (array_get a h))"
    by (simp_all add: list_map_invar_def)
  let ?h = "bhc (array_length a) k"
  from hlen bucket show "bucket_ok bhc (array_length ?a) h (array_get ?a h)"
    by(cases "h = ?h")(auto simp add: ahm_rehash_aux'_def Let_def array_length_ahm_rehash_aux' array_get_array_set_other dest: bucket_okD intro!: bucket_okI)
  from dist hlen fresh
  show "list_map_invar (array_get ?a h)"
    unfolding list_map_invar_def
    by(cases "h = ?h")(auto simp add: ahm_rehash_aux'_def Let_def array_get_array_set_other)
next
  let ?f = "λn kvs. n + length kvs"
  { fix n :: nat and xs :: "('a × 'b) list list"
    have "foldl ?f n xs = n + foldl ?f 0 xs"
      by(induct xs arbitrary:  rule: rev_induct) simp_all }
  note fold = this
  let ?h = "bhc (array_length a) k"

  obtain xs where a [simp]: "a = Array xs" by(cases a)
  from inv and bhc have [simp]: "bhc (length xs) k < length xs"
      by (force simp add: ahm_invar_aux_def)
  have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
  from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
    by(auto elim: ahm_invar_auxE)
  hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
    by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
  thus "Suc n = array_foldl (λ_ n kvs. n + length kvs) 0 ?a"
    by(simp add: ahm_rehash_aux'_def Let_def array_foldl_foldl foldl_list_update)(subst (1 2 3 4) fold, simp)
next
  from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
  thus "1 < array_length ?a" by(simp add: array_length_ahm_rehash_aux')
qed

(* TODO: Here be dragons *)


lemma ahm_rehash_aux_correct:
  fixes a :: "('k×'v) list array"
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  and inv: "ahm_invar_aux bhc n a"
  and "sz > 1"
  shows "ahm_invar_aux bhc n (ahm_rehash_aux bhc a sz)" (is "?thesis1")
  and "ahm_α_aux bhc (ahm_rehash_aux bhc a sz) = ahm_α_aux bhc a" (is "?thesis2")
proof -
  let ?a = "ahm_rehash_aux bhc a sz"
  define I where "I it a' 
   ahm_invar_aux bhc (n - card it) a' 
  array_length a' = sz 
  (k. if k  it then 
      ahm_α_aux bhc a' k = None 
      else ahm_α_aux bhc a' k = ahm_α_aux bhc a k)" for it a'

  note iterator_rule = map_iterator_no_cond_rule_P[
        OF ahm_iteratei_aux_impl[OF inv bhc], 
        of I "new_array [] sz" "ahm_rehash_aux' bhc sz" "I {}"]

  from inv have "I {} ?a" unfolding ahm_rehash_aux_def
  proof(intro iterator_rule)
    from ahm_invar_aux_card_dom_ahm_α_auxD[OF bhc inv] 
        have "card (dom (ahm_α_aux bhc a)) = n" .
    moreover from ahm_invar_aux_new_array[OF 1 < sz]
        have "ahm_invar_aux bhc 0 (new_array ([]::('k×'v) list) sz)" .
    moreover {
      fix k
      assume "k  dom (ahm_α_aux bhc a)"
      hence "ahm_α_aux bhc a k = None" by auto
      hence "ahm_α_aux bhc (new_array [] sz) k = ahm_α_aux bhc a k"
          using assms by simp
    }
    ultimately show "I (dom (ahm_α_aux bhc a)) (new_array [] sz)"
        using assms by (simp add: I_def)
  next
    fix k :: 'k
      and v :: 'v
      and it a'
    assume "k  it" "ahm_α_aux bhc a k = Some v" 
      and it_sub: "it  dom (ahm_α_aux bhc a)"
      and I: "I it a'"
    from I have inv': "ahm_invar_aux bhc (n - card it) a'" 
      and a'_eq_a: "k. k  it  ahm_α_aux bhc a' k = ahm_α_aux bhc a k" 
      and a'_None: "k. k  it  ahm_α_aux bhc a' k = None"
      and [simp]: "sz = array_length a'" 
      by (auto split: if_split_asm simp: I_def)
    from it_sub finite_dom_ahm_α_aux[OF bhc inv] 
        have "finite it" by(rule finite_subset)
    moreover with k  it have "card it > 0" by (auto simp add: card_gt_0_iff)
    moreover from finite_dom_ahm_α_aux[OF bhc inv] it_sub
        have "card it  card (dom (ahm_α_aux bhc a))" by (rule card_mono)
    moreover have " = n" using inv
        by(simp add: ahm_invar_aux_card_dom_ahm_α_auxD[OF bhc])
    ultimately have "n - card (it - {k}) = (n - card it) + 1" 
        using k  it by auto
    moreover from k  it have "ahm_α_aux bhc a' k = None" by (rule a'_None)
    hence "k  fst ` set (array_get a' (bhc (array_length a') k))"
        by (simp add: ahm_α_aux_def2 map_of_eq_None_iff)
    ultimately have "ahm_invar_aux bhc (n - card (it - {k})) 
        (ahm_rehash_aux' bhc sz (k, v) a')"
        using ahm_rehash_aux'_preserves_ahm_invar_aux[OF inv' bhc] by simp
    moreover have "array_length (ahm_rehash_aux' bhc sz (k, v) a') = sz"
        by (simp add: array_length_ahm_rehash_aux')
    moreover {
      fix k'
      assume "k'  it - {k}"
      with is_bounded_hashcodeD(3)[OF bhc 1 < sz, of k'] a'_None[of k']
      have "ahm_α_aux bhc (ahm_rehash_aux' bhc sz (k, v) a') k' = None"
          unfolding ahm_α_aux_def2
          by (cases "bhc sz k = bhc sz k'") (simp_all add: 
                  array_get_array_set_other ahm_rehash_aux'_def Let_def)
    } moreover {
      fix k'
      assume "k'  it - {k}"
      with is_bounded_hashcodeD(3)[OF bhc 1 < sz, of k]
           is_bounded_hashcodeD(3)[OF bhc 1 < sz, of k'] 
           a'_eq_a[of k'] k  it
      have "ahm_α_aux bhc (ahm_rehash_aux' bhc sz (k, v) a') k' = 
                ahm_α_aux bhc a k'"
          unfolding ahm_rehash_aux'_def Let_def 
          using ‹ahm_α_aux bhc a k = Some v
          unfolding ahm_α_aux_def2
        by(cases "bhc sz k = bhc sz k'") (case_tac [!] "k' = k", 
            simp_all add: array_get_array_set_other)
    }
    ultimately show "I (it - {k}) (ahm_rehash_aux' bhc sz (k, v) a')"
        unfolding I_def by simp
  qed simp_all
  thus ?thesis1 ?thesis2 unfolding ahm_rehash_aux_def I_def by auto
qed

lemma ahm_rehash_correct:
  fixes hm :: "('k, 'v) hashmap"
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  and inv: "ahm_invar bhc hm"
  and "sz > 1"
  shows "ahm_invar bhc (ahm_rehash bhc hm sz)" 
        "ahm_α bhc (ahm_rehash bhc hm sz) = ahm_α bhc hm"
proof-
  obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
  from inv have "ahm_invar_aux bhc n a" by simp
  from ahm_rehash_aux_correct[OF bhc this sz > 1]
      show "ahm_invar bhc (ahm_rehash bhc hm sz)" and
           "ahm_α bhc (ahm_rehash bhc hm sz) = ahm_α bhc hm"
      by (simp_all add: ahm_α_def2)
qed

subsection @{term ahm_update}

lemma param_hm_grow[param]:
  "(hm_grow, hm_grow)  Rk,Rvahm_map_rel  nat_rel"
unfolding hm_grow_def[abs_def] rec_hashmap_is_case by parametricity

lemma param_ahm_rehash_aux'[param]:
  assumes "is_bounded_hashcode Rk eq bhc"
  assumes "1 < n"
  assumes "(bhc,bhc')  nat_rel  Rk  nat_rel"
  assumes "(n,n')  nat_rel" and "n = array_length a"
  assumes "(kv,kv')  Rk,Rvprod_rel"
  assumes "(a,a')  Rk,Rvprod_rellist_relarray_rel"
  shows "(ahm_rehash_aux' bhc n kv a, ahm_rehash_aux' bhc' n' kv' a') 
             Rk,Rvprod_rellist_relarray_rel"
proof-
  from assms have "bhc n (fst kv) < array_length a" by force
  thus ?thesis unfolding ahm_rehash_aux'_def[abs_def] 
      rec_hashmap_is_case Let_def using assms by parametricity
qed

(* TODO: Move this *)
lemma param_new_array[param]: 
    "(new_array, new_array)  R  nat_rel  Rarray_rel"
unfolding new_array_def[abs_def] by parametricity

(* TODO: move *)
lemma param_foldli_induct:
  assumes l: "(l,l')  Ralist_rel"
  assumes c: "(c,c')  Rb  bool_rel"
  assumes σ: "(σ,σ')  Rb"
  assumes: "P σ σ'"
  assumes f: "a a' b b'. (a,a')Ra  (b,b')Rb  c b  c' b'  
                           P b b'  (f a b, f' a' b')  Rb  
                          P (f a b) (f' a' b')"
  shows "(foldli l c f σ, foldli l' c' f' σ')  Rb"
using c σ Pσ f by (induction arbitrary: σ σ' rule: list_rel_induct[OF l],
                   auto dest!: fun_relD)

lemma param_foldli_induct_nocond:
  assumes l: "(l,l')  Ralist_rel"
  assumes σ: "(σ,σ')  Rb"
  assumes: "P σ σ'"
  assumes f: "a a' b b'. (a,a')Ra  (b,b')Rb  P b b'  
                  (f a b, f' a' b')  Rb  P (f a b) (f' a' b')"
  shows "(foldli l (λ_. True) f σ, foldli l' (λ_. True) f' σ')  Rb"
  using assms by (blast intro: param_foldli_induct)

lemma param_ahm_rehash_aux[param]:
  assumes bhc: "is_bounded_hashcode Rk eq bhc"
  assumes bhc_rel: "(bhc,bhc')  nat_rel  Rk  nat_rel"
  assumes A: "(a,a')  Rk,Rvprod_rellist_relarray_rel"
  assumes N: "(n,n')  nat_rel" "1 < n"
  shows "(ahm_rehash_aux bhc a n, ahm_rehash_aux bhc' a' n')  
        Rk,Rvprod_rellist_relarray_rel"
proof-
  obtain l l' where [simp]: "a = Array l" "a' = Array l'"
      by (cases a, cases a')
  from A have L: "(l,l')  Rk,Rvprod_rellist_rellist_rel"
      unfolding array_rel_def by simp
  hence L': "(concat l, concat l')  Rk,Rvprod_rellist_rel"
      by parametricity
  let ?P = "λa a'. n = array_length a"

  note induct_rule = param_foldli_induct_nocond[OF L', where P="?P"]

  show ?thesis unfolding ahm_rehash_aux_def
      by (simp, induction rule: induct_rule, insert N bhc bhc_rel,
          auto intro: param_new_array[param_fo] 
                      param_ahm_rehash_aux'[param_fo] 
          simp: array_length_ahm_rehash_aux')
qed

(* TODO: Parametricity fails to prove this. Why? *)
lemma param_ahm_rehash[param]:
  assumes bhc: "is_bounded_hashcode Rk eq bhc"
  assumes bhc_rel: "(bhc,bhc')  nat_rel  Rk  nat_rel"
  assumes M: "(m,m')  Rk,Rvahm_map_rel"
  assumes N: "(n,n')  nat_rel" "1 < n"
  shows "(ahm_rehash bhc m n, ahm_rehash bhc' m' n') 
             Rk,Rvahm_map_rel"
proof-
  obtain a a' k k' where [simp]: "m = HashMap a k" "m' = HashMap a' k'"
      by (cases m, cases m')
  hence K: "(k,k')  nat_rel" and
        A: "(a,a')  Rk,Rvprod_rellist_relarray_rel"
      using M unfolding ahm_map_rel_def by simp_all
  show ?thesis unfolding ahm_rehash_def 
      by (simp, insert K A assms, parametricity)
qed

lemma param_load_factor[param]:
  "(load_factor, load_factor)  nat_rel" 
  unfolding load_factor_def by simp

lemma param_ahm_filled[param]: 
    "(ahm_filled, ahm_filled)  Rk,Rvahm_map_rel  bool_rel"
  unfolding ahm_filled_def[abs_def] rec_hashmap_is_case
  by parametricity

lemma param_ahm_update_aux[param]:
  assumes bhc: "is_bounded_hashcode Rk eq bhc"
  assumes bhc_rel: "(bhc,bhc')  nat_rel  Rk  nat_rel"
  assumes inv: "ahm_invar bhc' m'"
  assumes K: "(k,k')  Rk"
  assumes V: "(v,v')  Rv"
  assumes M: "(m,m')  Rk,Rvahm_map_rel"
  shows "(ahm_update_aux eq bhc m k v, 
          ahm_update_aux (=) bhc' m' k' v' )  Rk,Rvahm_map_rel"
proof-
  from bhc have eq[param]: "(eq, (=))Rk  Rk  bool_rel" by (simp add: is_bounded_hashcodeD)
  obtain a a' n n' where 
      [simp]: "m = HashMap a n" and [simp]: "m' = HashMap a' n'"
      by (cases m, cases m')
  from M have A: "(a,a')  Rk,Rvprod_rellist_relarray_rel" and 
              N: "(n,n')  nat_rel"
      unfolding ahm_map_rel_def by simp_all

  from inv have "1 < array_length a'"
      unfolding ahm_invar_def ahm_invar_aux_def by force
  hence "1 < array_length a"
      by (simp add: array_rel_imp_same_length[OF A])
  with bhc have bhc_range: "bhc (array_length a) k < array_length a" by blast

  have option_compare: "a a'. (a,a')  Rvoption_rel 
                            (a = None,a' = None)  bool_rel" by force
  have "(array_get a (bhc (array_length a) k),  
         array_get a' (bhc' (array_length a') k'))  
         Rk,Rvprod_rellist_rel"
    using A K bhc_rel bhc_range by parametricity
  note cmp = option_compare[OF param_list_map_lookup[param_fo, OF eq K this]]
  
  show ?thesis apply simp
    unfolding ahm_update_aux_def Let_def rec_hashmap_is_case
    using assms A N bhc_range cmp by parametricity 
qed


lemma param_ahm_update[param]:
  assumes bhc: "is_bounded_hashcode Rk eq bhc"
  assumes bhc_rel: "(bhc,bhc')  nat_rel  Rk  nat_rel"
  assumes inv: "ahm_invar bhc' m'"
  assumes K: "(k,k')  Rk"
  assumes V: "(v,v')  Rv"
  assumes M: "(m,m')  Rk,Rvahm_map_rel"
  shows "(ahm_update eq bhc k v m, ahm_update (=) bhc' k' v' m')  
             Rk,Rvahm_map_rel"
proof-
  have "1 < hm_grow (ahm_update_aux eq bhc m k v)" by simp
  with assms show ?thesis unfolding ahm_update_def[abs_def] Let_def
      by parametricity
qed


(* TODO: Move *)
lemma length_list_map_update:
  "length (list_map_update (=) k v xs) =
    (if list_map_lookup (=) k xs = None then Suc (length xs) else length xs)"
        (is "?l_new = _")
proof (cases "list_map_lookup (=) k xs", simp_all)
  case None
    hence "k  dom (map_of xs)" by (force simp: list_map_lookup_is_map_of)
    hence "a. list_map_update_aux (=) k v xs a = (k,v) # rev xs @ a"
        by (induction xs, auto)
    thus "?l_new = Suc (length xs)" unfolding list_map_update_def by simp
next
  case (Some v')
    hence "(k,v')  set xs" unfolding list_map_lookup_is_map_of
        by (rule map_of_SomeD)
    hence "a. length (list_map_update_aux (=) k v xs a) = 
        length xs + length a" by (induction xs, auto)
    thus "?l_new = length xs" unfolding list_map_update_def by simp
qed
  
lemma length_list_map_delete:
  "length (list_map_delete (=) k xs) =
    (if list_map_lookup (=) k xs = None then length xs else length xs - 1)"
        (is "?l_new = _")
proof (cases "list_map_lookup (=) k xs", simp_all)
  case None
    hence "k  dom (map_of xs)" by (force simp: list_map_lookup_is_map_of)
    hence "a. list_map_delete_aux (=) k xs a = rev xs @ a"
        by (induction xs, auto)
    thus "?l_new = length xs" unfolding list_map_delete_def by simp
next
  case (Some v')
    hence "(k,v')  set xs" unfolding list_map_lookup_is_map_of
        by (rule map_of_SomeD)
    hence "a. k  fst`set a  length (list_map_delete_aux (=) k xs a) = 
        length xs + length a - 1" by (induction xs, auto)
    thus "?l_new = length xs - Suc 0" unfolding list_map_delete_def by simp
qed
    


lemma ahm_update_impl:
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  shows "(ahm_update (=) bhc, op_map_update)  (Id::('k×'k) set)  
              (Id::('v×'v) set)  ahm_map_rel' bhc  ahm_map_rel' bhc"
proof (intro fun_relI, clarsimp)
  fix k::'k and v::'v and hm::"('k,'v) hashmap" and  m::"'k'v"
  assume "(hm,m)  ahm_map_rel' bhc"
  hence α: "m = ahm_α bhc hm" and inv: "ahm_invar bhc hm"
      unfolding ahm_map_rel'_def br_def by simp_all
  obtain a n where [simp]: "hm = HashMap a n" by (cases hm)

  have K: "(k,k)  Id" and V: "(v,v)  Id" by simp_all

  from inv have [simp]: "1 < array_length a"
      unfolding ahm_invar_def ahm_invar_aux_def by simp
  hence bhc_range[simp]: "k. bhc (array_length a) k < array_length a"
      using bhc by blast

  let ?l = "array_length a"
  let ?h = "bhc (array_length a) k"
  let ?a' = "array_set a ?h (list_map_update (=) k v (array_get a ?h))"
  let ?n' = "if list_map_lookup (=) k (array_get a ?h) = None 
                 then n + 1 else n"

  let ?list = "array_get a (bhc ?l k)"
  let ?list' = "map_of ?list"
  have L: "(?list, ?list')  br map_of list_map_invar"
      using inv unfolding ahm_invar_def ahm_invar_aux_def br_def by simp
  hence list: "list_map_invar ?list" by (simp_all add: br_def)
  let ?list_new = "list_map_update (=) k v ?list"
  let ?list_new' = "op_map_update k v (map_of (?list))"
  from list_map_autoref_update2[param_fo, OF K V L]
      have list_updated: "map_of ?list_new = ?list_new'" 
           "list_map_invar ?list_new" unfolding br_def by simp_all

  have "ahm_invar bhc (HashMap ?a' ?n')" unfolding ahm_invar.simps
  proof(rule ahm_invar_auxI)
    fix h
    assume "h < array_length ?a'"
    hence h_in_range: "h < array_length a" by simp
    with inv have bucket_ok: "bucket_ok bhc ?l h (array_get a h)"
        by(auto elim: ahm_invar_auxD)
    thus "bucket_ok bhc (array_length ?a') h (array_get ?a' h)"
      proof (cases "h = bhc (array_length a) k")
        case False 
          with bucket_ok show ?thesis
              by (intro bucket_okI, force simp add: 
                  array_get_array_set_other dest: bucket_okD)
      next
        case True
          show ?thesis
          proof (insert True, simp, intro bucket_okI, goal_cases)
            case prems: (1 k')
              show ?case
              proof (cases "k = k'")
                case False
                  from prems have "k'  dom ?list_new'"
                      by (simp only: dom_map_of_conv_image_fst 
                          list_updated(1)[symmetric])
                  hence "k'  fst`set ?list" using False
                      by (simp add: dom_map_of_conv_image_fst)
                  from imageE[OF this] obtain x where 
                      "fst x = k'" and "x  set ?list" by force
                  then obtain v' where "(k',v')  set ?list"
                       by (cases x, simp)
                  with bucket_okD[OF bucket_ok] and 
                      h = bhc (array_length a) k
                      show ?thesis by simp
             qed simp
          qed
      qed
    from h < array_length a inv have "list_map_invar (array_get a h)"
        by(auto dest: ahm_invar_auxD)
    with h < array_length a
    show "list_map_invar (array_get ?a' h)"
        by (cases "h = ?h", simp_all add: 
            list_updated array_get_array_set_other)
  next

    obtain xs where a [simp]: "a = Array xs" by(cases a)

    let ?f = "λn kvs. n + length kvs"
    { fix n :: nat and xs :: "('k × 'v) list list"
      have "foldl ?f n xs = n + foldl ?f 0 xs"
        by(induct xs arbitrary:  rule: rev_induct) simp_all }
    note fold = this

    from inv have [simp]: "bhc (length xs) k < length xs"
        using bhc_range by simp
    have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs"
        by(simp add: Cons_nth_drop_Suc)
    from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
        by (force dest: ahm_invar_auxD)
    hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
      apply (simp add: array_foldl_foldl)
      apply (subst xs)
      apply simp
      apply (metis fold)
      done
    thus "?n' = array_foldl (λ_ n kvs. n + length kvs) 0 ?a'"
      apply(simp add: ahm_rehash_aux'_def Let_def array_foldl_foldl foldl_list_update map_of_eq_None_iff)
      apply(subst (1 2 3 4 5 6 7 8) fold)
      apply(simp add: length_list_map_update)
      done
  next
    from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
    thus "1 < array_length ?a'" by simp
  next
  qed

  moreover have "ahm_α bhc (ahm_update_aux (=) bhc hm k v) = 
                     ahm_α bhc hm(k  v)"
  proof
    fix k'
    show "ahm_α bhc (ahm_update_aux (=) bhc hm k v) k' = (ahm_α bhc hm(k  v)) k'"
    proof (cases "bhc ?l k = bhc ?l k'") 
      case False
        thus ?thesis by (force simp add: Let_def 
            ahm_α_def array_get_array_set_other)
    next
      case True
        hence "bhc ?l k' = bhc ?l k" by simp
        thus ?thesis by (auto simp add: Let_def ahm_α_def 
            list_map_lookup_is_map_of list_updated)
    qed
  qed

  ultimately have ref: "(ahm_update_aux (=) bhc hm k v, 
                    m(k  v))  ahm_map_rel' bhc" (is "(?hm',_)_")
  unfolding ahm_map_rel'_def br_def using α by (auto simp: Let_def)

  show "(ahm_update (=) bhc k v hm, m(k  v))
             ahm_map_rel' bhc"
  proof (cases "ahm_filled ?hm'")
    case False
      with ref show ?thesis unfolding ahm_update_def
          by (simp del: ahm_update_aux.simps)
  next
    case True
      from ref have "(ahm_rehash bhc ?hm' (hm_grow ?hm'), m(k  v))  
          ahm_map_rel' bhc" unfolding ahm_map_rel'_def br_def
          by (simp del: ahm_update_aux.simps 
                   add: ahm_rehash_correct[OF bhc])
      thus ?thesis unfolding ahm_update_def using True
          by (simp del: ahm_update_aux.simps add: Let_def)
  qed
qed

lemma autoref_ahm_update[autoref_rules]:
  assumes bhc[unfolded autoref_tag_defs]: 
    "SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
  shows "(ahm_update eq bhc, op_map_update)  
              Rk  Rv  Rk,Rvahm_rel bhc  Rk,Rvahm_rel bhc"
proof (intro fun_relI)
  let ?bhc' = "abstract_bounded_hashcode Rk bhc"
  fix k k' v v' a m'
  assume K: "(k,k')  Rk" and V: "(v,v')  Rv"
  assume M: "(a,m')  Rk,Rvahm_rel bhc"
  (*from eq have eq': "(eq,(=)) ∈ Rk → Rk → bool_rel" by simp*)
  with bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'" by blast
  from abstract_bhc_correct[OF bhc] 
      have bhc_rel: "(bhc,?bhc')  nat_rel  Rk  nat_rel" .

  from M obtain a' where M1: "(a,a')  Rk,Rvahm_map_rel" and
      M2: "(a',m')  ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
  hence inv: "ahm_invar ?bhc' a'" 
      unfolding ahm_map_rel'_def br_def by simp


  from relcompI[OF param_ahm_update[OF bhc bhc_rel inv K V M1]
                   ahm_update_impl[param_fo, OF bhc' _ _ M2]]
  show "(ahm_update eq bhc k v a, op_map_update k' v' m')  
            Rk,Rvahm_rel bhc" unfolding ahm_rel_def by simp
qed

subsection @{term "ahm_delete"}

lemma param_ahm_delete[param]:
  (*assumes eq: "(eq,(=)) ∈ Rk → Rk → bool_rel"*)
  assumes isbhc: "is_bounded_hashcode Rk eq bhc"
  assumes bhc: "(bhc,bhc')  nat_rel  Rk  nat_rel"
  assumes inv: "ahm_invar bhc' m'"
  assumes K: "(k,k')  Rk"
  assumes M: "(m,m')  Rk,Rvahm_map_rel"
  shows
  "(ahm_delete eq bhc k m, ahm_delete (=) bhc' k' m')  
       Rk,Rvahm_map_rel"
proof-
  from isbhc have eq: "(eq,(=))RkRkbool_rel" by (simp add: is_bounded_hashcodeD)

  obtain a a' n n' where 
      [simp]: "m = HashMap a n" and [simp]: "m' = HashMap a' n'"
      by (cases m, cases m')
  from M have A: "(a,a')  Rk,Rvprod_rellist_relarray_rel" and 
              N: "(n,n')  nat_rel"
      unfolding ahm_map_rel_def by simp_all

  from inv have "1 < array_length a'"
      unfolding ahm_invar_def ahm_invar_aux_def by force
  hence "1 < array_length a"
      by (simp add: array_rel_imp_same_length[OF A])
  with isbhc have bhc_range: "bhc (array_length a) k < array_length a" by blast

  have option_compare: "a a'. (a,a')  Rvoption_rel 
                            (a = None,a' = None)  bool_rel" by force
  have "(array_get a (bhc (array_length a) k),  
         array_get a' (bhc' (array_length a') k'))  
         Rk,Rvprod_rellist_rel"
      using A K bhc bhc_range by parametricity
  note cmp = option_compare[OF param_list_map_lookup[param_fo, OF eq K this]]

  show ?thesis unfolding m = HashMap a n m' = HashMap a' n'
      by (simp only: ahm_delete.simps Let_def,
             insert eq isbhc bhc K A N bhc_range cmp, parametricity)
qed


lemma ahm_delete_impl:
  assumes bhc: "is_bounded_hashcode Id (=) bhc"
  shows "(ahm_delete (=) bhc, op_map_delete)  (Id::('k×'k) set)  
              ahm_map_rel' bhc  ahm_map_rel' bhc"
proof (intro fun_relI, clarsimp)
  fix k::'k and hm::"('k,'v) hashmap" and  m::"'k'v"
  assume "(hm,m)  ahm_map_rel' bhc"
  hence α: "m = ahm_α bhc hm" and inv: "ahm_invar bhc hm"
      unfolding ahm_map_rel'_def br_def by simp_all
  obtain a n where [simp]: "hm = HashMap a n" by (cases hm)

  have K: "(k,k)  Id" by simp

  from inv have [simp]: "1 < array_length a"
      unfolding ahm_invar_def ahm_invar_aux_def by simp
  hence bhc_range[simp]: "k. bhc (array_length a) k < array_length a"
      using bhc by blast

  let ?l = "array_length a"
  let ?h = "bhc ?l k"
  let ?a' = "array_set a ?h (list_map_delete (=) k (array_get a ?h))"
  let ?n' = "if list_map_lookup (=) k (array_get a ?h) = None then n else n - 1"
  let ?list = "array_get a ?h" let ?list' = "map_of ?list"
  let ?list_new = "list_map_delete (=) k ?list"
  let ?list_new' = "?list' |` (-{k})"
  from inv have "(?list, ?list')  br map_of list_map_invar"
      unfolding br_def ahm_invar_def ahm_invar_aux_def by simp
  from list_map_autoref_delete2[param_fo, OF K this]
      have list_updated: "map_of ?list_new = ?list_new'"
           "list_map_invar ?list_new" by (simp_all add: br_def)
  
  have [simp]: "array_length ?a' = ?l" by simp

  have "ahm_invar_aux bhc ?n' ?a'"
  proof(rule ahm_invar_auxI)
    fix h
    assume "h < array_length ?a'"
    hence h_in_range[simp]: "h < array_length a" by simp
    with inv have inv': "bucket_ok bhc ?l h (array_get a h)" "1 < ?l" 
        "list_map_invar (array_get a h)" by (auto elim: ahm_invar_auxE)

    show "bucket_ok bhc (array_length ?a') h (array_get ?a' h)"
      proof (cases "h = bhc ?l k")
        case False thus ?thesis using inv'
            by (simp add: array_get_array_set_other)
      next
        case True thus ?thesis
        proof (simp, intro bucket_okI, goal_cases)
          case prems: (1 k')
              show ?case
              proof (cases "k = k'")
                case False
                  from prems have "k'  dom ?list_new'"
                      by (simp only: dom_map_of_conv_image_fst 
                          list_updated(1)[symmetric])
                  hence "k'  fst`set ?list" using False
                      by (simp add: dom_map_of_conv_image_fst)
                  from imageE[OF this] obtain x where 
                      "fst x = k'" and "x  set ?list" by force
                  then obtain v' where "(k',v')  set ?list"
                       by (cases x, simp)
                  with bucket_okD[OF inv'(1)] and 
                      h = bhc (array_length a) k
                      show ?thesis by blast
             qed simp
        qed
      qed
    
    from inv'(3) h < array_length a
    show "list_map_invar (array_get ?a' h)"
        by (cases "h = ?h", simp_all add: 
            list_updated array_get_array_set_other)
  next
    obtain xs where a [simp]: "a = Array xs" by(cases a)

    let ?f = "λn kvs. n + length (kvs::('k×'v) list)"
    { fix n :: nat and xs :: "('k×'v) list list"
      have "foldl ?f n xs = n + foldl ?f 0 xs"
        by(induct xs arbitrary:  rule: rev_induct) simp_all }
    note fold = this

    from bhc_range have [simp]: "bhc (length xs) k < length xs" by simp
    moreover
    have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
    from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
      by(auto elim: ahm_invar_auxE)
    hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
      by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
    moreover have "v a b. list_map_lookup (=) k (xs ! ?h) = Some v
         a + (length (xs ! ?h) - 1) + b = a + length (xs ! ?h) + b - 1"
         by (cases "xs ! ?h", simp_all)
    ultimately show "?n' = array_foldl (λ_ n kvs. n + length kvs) 0 ?a'"
      apply(simp add: array_foldl_foldl foldl_list_update map_of_eq_None_iff)
      apply(subst (1 2 3 4 5 6 7 8) fold)
apply (intro conjI impI)
      apply(auto simp add: length_list_map_delete)
      done
  next

    from inv show "1 < array_length ?a'" by(auto elim: ahm_invar_auxE)
  qed
  hence "ahm_invar bhc (HashMap ?a' ?n')" by simp

  moreover have "ahm_α_aux bhc ?a' = ahm_α_aux bhc a |` (- {k})"
  proof
    fix k' :: 'k
    show "ahm_α_aux bhc ?a' k' = (ahm_α_aux bhc a |` (- {k})) k'"
    proof (cases "bhc ?l k' = ?h")
      case False
        hence "k  k'" by force
        thus ?thesis using False unfolding ahm_α_aux_def 
            by (simp add: array_get_array_set_other 
                          list_map_lookup_is_map_of)
    next
      case True
        thus ?thesis unfolding ahm_α_aux_def 
            by (simp add: list_map_lookup_is_map_of 
                       list_updated(1) restrict_map_def)
    qed
  qed 
  hence "ahm_α bhc (HashMap ?a' ?n') = op_map_delete k m"
      unfolding op_map_delete_def by (simp add: ahm_α_def2 α)
  
  ultimately have "(HashMap ?a' ?n', op_map_delete k m)  ahm_map_rel' bhc"
      unfolding ahm_map_rel'_def br_def by simp

  thus "(ahm_delete (=) bhc k hm, m |` (-{k}))  ahm_map_rel' bhc"
      by (simp only: hm = HashMap a n ahm_delete.simps Let_def 
                 op_map_delete_def, force)
qed

lemma autoref_ahm_delete[autoref_rules]:
  assumes bhc[unfolded autoref_tag_defs]: 
    "SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
  shows "(ahm_delete eq bhc, op_map_delete)  
              Rk  Rk,Rvahm_rel bhc  Rk,Rvahm_rel bhc"
proof (intro fun_relI)
  let ?bhc' = "abstract_bounded_hashcode Rk bhc"
  fix k k' a m'
  assume K: "(k,k')  Rk"
  assume M: "(a,m')  Rk,Rvahm_rel bhc"
  (*from bhc have eq': "(eq,(=)) ∈ Rk → Rk → bool_rel" by (simp add: is_bounded_hashcodeD)*)
  with bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'" by blast
  from abstract_bhc_correct[OF bhc] 
      have bhc_rel: "(bhc,?bhc')  nat_rel  Rk  nat_rel" .

  from M obtain a' where M1: "(a,a')  Rk,Rvahm_map_rel" and
      M2: "(a',m')  ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast
  hence inv: "ahm_invar ?bhc' a'" 
      unfolding ahm_map_rel'_def br_def by simp

  from relcompI[OF param_ahm_delete[OF bhc bhc_rel inv K M1]
                   ahm_delete_impl[param_fo, OF bhc' _ M2]]
  show "(ahm_delete eq bhc k a, op_map_delete k' m')  
            Rk,Rvahm_rel bhc" unfolding ahm_rel_def by simp
qed


subsection ‹Various simple operations›

lemma param_ahm_isEmpty[param]: 
    "(ahm_isEmpty, ahm_isEmpty)  Rk,Rvahm_map_rel  bool_rel"
unfolding ahm_isEmpty_def[abs_def] rec_hashmap_is_case
by parametricity

lemma param_ahm_isSng[param]: 
    "(ahm_isSng, ahm_isSng)  Rk,Rvahm_map_rel  bool_rel"
unfolding ahm_isSng_def[abs_def] rec_hashmap_is_case
by parametricity

lemma param_ahm_size[param]: 
    "(ahm_size, ahm_size)  Rk,Rvahm_map_rel  nat_rel"
unfolding ahm_size_def[abs_def] rec_hashmap_is_case
by parametricity


lemma ahm_isEmpty_impl:
  assumes "is_bounded_hashcode Id (=) bhc"
  shows "(ahm_isEmpty, op_map_isEmpty)  ahm_map_rel' bhc  bool_rel"
proof (intro fun_relI)
  fix hm m assume rel: "(hm,m)  ahm_map_rel' bhc"
  obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
  from rel have α: "m = ahm_α_aux bhc a" and inv: "ahm_invar_aux bhc n a"
      unfolding ahm_map_rel'_def br_def by (simp_all add: ahm_α_def2)
  from ahm_invar_aux_card_dom_ahm_α_auxD[OF assms inv,symmetric] and
       finite_dom_ahm_α_aux[OF assms inv]
      show "(ahm_isEmpty hm, op_map_isEmpty m)  bool_rel"
          unfolding ahm_isEmpty_def op_map_isEmpty_def
          by (simp add: α card_eq_0_iff)
qed

lemma ahm_isSng_impl:
  assumes "is_bounded_hashcode Id (=) bhc"
  shows "(ahm_isSng, op_map_isSng)  ahm_map_rel' bhc  bool_rel"
proof (intro fun_relI)
  fix hm m assume rel: "(hm,m)  ahm_map_rel' bhc"
  obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
  from rel have α: "m = ahm_α_aux bhc a" and inv: "ahm_invar_aux bhc n a"
      unfolding ahm_map_rel'_def br_def by (simp_all add: ahm_α_def2)
  note n_props[simp] = ahm_invar_aux_card_dom_ahm_α_auxD[OF assms inv,symmetric]
  note finite_dom[simp] =  finite_dom_ahm_α_aux[OF assms inv]
  show "(ahm_isSng hm, op_map_isSng m)  bool_rel"
      by (force simp add: α[symmetric] dom_eq_singleton_conv 
                dest!: card_eq_SucD)
qed

lemma ahm_size_impl:
  assumes "is_bounded_hashcode Id (=) bhc"
  shows "(ahm_size, op_map_size)  ahm_map_rel' bhc  nat_rel"
proof (intro fun_relI)
  fix hm m assume rel: "(hm,m)  ahm_map_rel' bhc"
  obtain a n where [simp]: "hm = HashMap a n" by (cases hm)
  from rel have α: "m = ahm_α_aux bhc a" and inv: "ahm_invar_aux bhc n a"
      unfolding ahm_map_rel'_def br_def by (simp_all add: ahm_α_def2)
  from ahm_invar_aux_card_dom_ahm_α_auxD[OF assms inv,symmetric]
      show "(ahm_size hm, op_map_size m)  nat_rel"
          unfolding ahm_isEmpty_def op_map_isEmpty_def
          by (simp add: α card_eq_0_iff)
qed


lemma autoref_ahm_isEmpty[autoref_rules]:
  (*assumes eq: "GEN_OP eq (=) (Rk → Rk → bool_rel)"*)
  assumes bhc[unfolded autoref_tag_defs]: 
      "SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
  shows "(ahm_isEmpty, op_map_isEmpty)  Rk,Rvahm_rel bhc  bool_rel"
proof (intro fun_relI)
  let ?bhc' = "abstract_bounded_hashcode Rk bhc"
  fix k k' a m'
  assume M: "(a,m')  Rk,Rvahm_rel bhc"
  (*from eq have "(eq,(=)) ∈ Rk → Rk → bool_rel" by simp*)
  from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'" 
    by blast

  from M obtain a' where M1: "(a,a')  Rk,Rvahm_map_rel" and
      M2: "(a',m')  ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast

  from relcompI[OF param_ahm_isEmpty[param_fo, OF M1]
                   ahm_isEmpty_impl[param_fo, OF bhc' M2]]
  show "(ahm_isEmpty a, op_map_isEmpty m')  bool_rel" by simp
qed

lemma autoref_ahm_isSng[autoref_rules]:
  assumes bhc[unfolded autoref_tag_defs]: 
      "SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
  shows "(ahm_isSng, op_map_isSng)  Rk,Rvahm_rel bhc  bool_rel"
proof (intro fun_relI)
  let ?bhc' = "abstract_bounded_hashcode Rk bhc"
  fix k k' a m'
  assume M: "(a,m')  Rk,Rvahm_rel bhc"
  from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'" 
    by blast

  from M obtain a' where M1: "(a,a')  Rk,Rvahm_map_rel" and
      M2: "(a',m')  ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast

  from relcompI[OF param_ahm_isSng[param_fo, OF M1]
                   ahm_isSng_impl[param_fo, OF bhc' M2]]
  show "(ahm_isSng a, op_map_isSng m')  bool_rel" by simp
qed

lemma autoref_ahm_size[autoref_rules]:
  assumes bhc[unfolded autoref_tag_defs]: 
      "SIDE_GEN_ALGO (is_bounded_hashcode Rk eq bhc)"
  shows "(ahm_size, op_map_size)  Rk,Rvahm_rel bhc  nat_rel"
proof (intro fun_relI)
  let ?bhc' = "abstract_bounded_hashcode Rk bhc"
  fix k k' a m'
  assume M: "(a,m')  Rk,Rvahm_rel bhc"
  from bhc have bhc': "is_bounded_hashcode Id (=) ?bhc'" 
    by blast

  from M obtain a' where M1: "(a,a')  Rk,Rvahm_map_rel" and
      M2: "(a',m')  ahm_map_rel' ?bhc'" unfolding ahm_rel_def by blast

  from relcompI[OF param_ahm_size[param_fo, OF M1]
                   ahm_size_impl[param_fo, OF bhc' M2]]
  show "(ahm_size a, op_map_size m')  nat_rel" by simp
qed

lemma ahm_map_rel_sv[relator_props]:
  assumes SK: "single_valued Rk" 
  assumes SV: "single_valued Rv"
  shows "single_valued (Rk, Rvahm_map_rel)"
proof -
  from SK SV have 1: "single_valued (Rk, Rvprod_rellist_relarray_rel)"
    by (tagged_solver)

  thus ?thesis
    unfolding ahm_map_rel_def
    by (auto intro: single_valuedI dest: single_valuedD[OF 1])
qed

lemma ahm_rel_sv[relator_props]:
  "single_valued Rk; single_valued Rv 
   single_valued (Rk,Rvahm_rel bhc)"
  unfolding ahm_rel_def ahm_map_rel'_def
  by (tagged_solver (keep))

lemma rbt_map_rel_finite[relator_props]: 
  assumes A[simplified]: "GEN_ALGO_tag (is_bounded_hashcode Rk eq bhc)"
  shows "finite_map_rel (Rk,Rvahm_rel bhc)"
  unfolding ahm_rel_def finite_map_rel_def ahm_map_rel'_def br_def
  apply auto
  apply (case_tac y)
  apply (auto simp: ahm_α_def2)
  thm finite_dom_ahm_α_aux
  apply (rule finite_dom_ahm_α_aux)
  apply (rule abstract_bhc_is_bhc)
  apply (rule A)
  apply assumption
  done

subsection ‹Proper iterator proofs›

lemma pi_ahm[icf_proper_iteratorI]: 
  "proper_it (ahm_iteratei m) (ahm_iteratei m)"
proof-
  obtain a n where [simp]: "m = HashMap a n" by (cases m)
  then obtain l where [simp]: "a = Array l" by (cases a)
  thus ?thesis
    unfolding proper_it_def list_map_iteratei_def
    by (simp add: ahm_iteratei_aux_def, blast)
qed

lemma pi'_ahm[icf_proper_iteratorI]: 
  "proper_it' ahm_iteratei ahm_iteratei"
  by (rule proper_it'I, rule pi_ahm)


(*
hide_const (open) HashMap bucket_ok ahm_invar ahm_α
  ahm_rehash hm_grow ahm_filled
hide_type (open) hashmap
*)


lemmas autoref_ahm_rules = 
  autoref_ahm_empty 
  autoref_ahm_lookup 
  autoref_ahm_update
  autoref_ahm_delete
  autoref_ahm_isEmpty
  autoref_ahm_isSng
  autoref_ahm_size

lemmas autoref_ahm_rules_hashable[autoref_rules_raw]
  = autoref_ahm_rules[where Rk="Rk"] for Rk :: "(_×_::hashable) set"


end

Theory Impl_RBT_Map

section ‹\isaheader{Red-Black Tree based Maps}›
theory Impl_RBT_Map
imports 
  "HOL-Library.RBT_Impl"
  "../../Lib/RBT_add"
  Automatic_Refinement.Automatic_Refinement
  "../../Iterator/Iterator"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
begin

(* TODO: Move to common/RBT_add (replace) *)

subsection ‹Standard Setup›

  inductive_set color_rel where
    "(color.R,color.R)  color_rel"
   | "(color.B,color.B)  color_rel"

  inductive_cases color_rel_elims:
    "(x,color.R)  color_rel"
    "(x,color.B)  color_rel"
    "(color.R,y)  color_rel"
    "(color.B,y)  color_rel"

  thm color_rel_elims

  lemma param_color[param]:
    "(color.R,color.R)color_rel"
    "(color.B,color.B)color_rel"
    "(case_color,case_color)R  R  color_rel  R"
    by (auto 
      intro: color_rel.intros
      elim: color_rel.cases
      split: color.split)

  inductive_set rbt_rel_aux for Ra Rb where
    "(rbt.Empty,rbt.Empty)rbt_rel_aux Ra Rb"
  | " (c,c')color_rel; 
       (l,l')rbt_rel_aux Ra Rb; (a,a')Ra; (b,b')Rb; 
       (r,r')rbt_rel_aux Ra Rb 
     (rbt.Branch c l a b r, rbt.Branch c' l' a' b' r')rbt_rel_aux Ra Rb"

  inductive_cases rbt_rel_aux_elims:  (* Argh! This seems to use 
    the default simpset to simplify the result. If relators are in this 
    simpset, we get an undesired result! *)
    "(x,rbt.Empty)rbt_rel_aux Ra Rb"
    "(rbt.Empty,x')rbt_rel_aux Ra Rb"
    "(rbt.Branch c l a b r,x')rbt_rel_aux Ra Rb"
    "(x,rbt.Branch c' l' a' b' r')rbt_rel_aux Ra Rb"

  definition "rbt_rel  rbt_rel_aux"
  lemma rbt_rel_aux_fold: "rbt_rel_aux Ra Rb  Ra,Rbrbt_rel"
    by (simp add: rbt_rel_def relAPP_def)

  lemmas rbt_rel_intros = rbt_rel_aux.intros[unfolded rbt_rel_aux_fold]
  lemmas rbt_rel_cases = rbt_rel_aux.cases[unfolded rbt_rel_aux_fold]
  lemmas rbt_rel_induct[induct set] 
    = rbt_rel_aux.induct[unfolded rbt_rel_aux_fold]
  lemmas rbt_rel_elims = rbt_rel_aux_elims[unfolded rbt_rel_aux_fold]

  lemma param_rbt1[param]: 
    "(rbt.Empty,rbt.Empty)  Ra,Rbrbt_rel"
    "(rbt.Branch,rbt.Branch)  
      color_rel  Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
    by (auto intro: rbt_rel_intros)

  lemma param_case_rbt[param]:
    "(case_rbt,case_rbt)  
      Ra  (color_rel  Rb,Rcrbt_rel  Rb  Rc  Rb,Rcrbt_rel  Ra) 
         Rb,Rcrbt_rel  Ra"
    apply clarsimp
    apply (erule rbt_rel_cases)
    apply simp
    apply simp
    apply parametricity
    done

  lemma param_rec_rbt[param]: "(rec_rbt, rec_rbt)  
    Ra  (color_rel  Rb,Rcrbt_rel  Rb  Rc  Rb,Rcrbt_rel
      Ra  Ra  Ra)  Rb,Rcrbt_rel  Ra"
  proof (intro fun_relI, goal_cases)
    case (1 s s' f f' t t') from this(3,1,2) show ?case
      apply (induct arbitrary: s s')
      apply simp
      apply simp
      apply parametricity
      done
  qed

  lemma param_paint[param]: 
    "(paint,paint)color_rel  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
    unfolding paint_def
    by parametricity

  lemma param_balance[param]: 
    shows "(balance,balance)  
      Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
  proof (intro fun_relI, goal_cases)
    case (1 t1 t1' a a' b b' t2 t2')
    thus ?case
      apply (induct t1' a' b' t2' arbitrary: t1 a b t2 rule: balance.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: balance.simps)
      apply (parametricity)+
      done
  qed


  lemma param_rbt_ins[param]:
    fixes less
    assumes param_less[param]: "(less,less')  Ra  Ra  Id"
    shows "(ord.rbt_ins less,ord.rbt_ins less')  
             (RaRbRbRb)  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
  proof (intro fun_relI, goal_cases)
    case (1 f f' a a' b b' t t')
    thus ?case
      apply (induct f' a' b' t' arbitrary: f a b t rule: ord.rbt_ins.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: ord.rbt_ins.simps rbt_ins.simps)
      apply parametricity+
      done
  qed

  term rbt_insert
  lemma param_rbt_insert[param]:
    fixes less
    assumes param_less[param]: "(less,less')  Ra  Ra  Id"
    shows "(ord.rbt_insert less,ord.rbt_insert less')  
      Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
    unfolding rbt_insert_def ord.rbt_insert_def
    unfolding rbt_insert_with_key_def[abs_def] 
      ord.rbt_insert_with_key_def[abs_def] 
    by parametricity

  lemma param_rbt_lookup[param]:
    fixes less
    assumes param_less[param]: "(less,less')  Ra  Ra  Id"
    shows "(ord.rbt_lookup less,ord.rbt_lookup less')  
             Ra,Rbrbt_rel  Ra  Rboption_rel"
    unfolding rbt_lookup_def ord.rbt_lookup_def
    by parametricity

  term balance_left
  lemma param_balance_left[param]: 
    "(balance_left, balance_left)  
      Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
  proof (intro fun_relI, goal_cases)
    case (1 l l' a a' b b' r r')
    thus ?case
      apply (induct l a b r arbitrary: l' a' b' r' rule: balance_left.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: balance_left.simps)
      apply parametricity+
      done
  qed

  term balance_right
  lemma param_balance_right[param]: 
    "(balance_right, balance_right)  
      Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
  proof (intro fun_relI, goal_cases)
    case (1 l l' a a' b b' r r')
    thus ?case
      apply (induct l a b r arbitrary: l' a' b' r' rule: balance_right.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: balance_right.simps)
      apply parametricity+
      done
  qed

  lemma param_combine[param]:
    "(combine,combine)Ra,Rbrbt_rel  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
  proof (intro fun_relI, goal_cases)
    case (1 t1 t1' t2 t2')
    thus ?case
      apply (induct t1 t2 arbitrary: t1' t2' rule: combine.induct)
      apply (elim_all rbt_rel_elims color_rel_elims)
      apply (simp_all only: combine.simps)
      apply parametricity+
      done
  qed

  lemma ih_aux1: " (a',b)R; a'=a   (a,b)R" by auto
  lemma is_eq: "a=b  a=b" .

  lemma param_rbt_del_aux:
    fixes br
    fixes less
    assumes param_less[param]: "(less,less')  Ra  Ra  Id"
    shows
    " (ak1,ak1')Ra; (al,al')Ra,Rbrbt_rel; (ak,ak')Ra;
      (av,av')Rb; (ar,ar')Ra,Rbrbt_rel 
      (ord.rbt_del_from_left less ak1 al ak av ar, 
      ord.rbt_del_from_left less' ak1' al' ak' av' ar') 
     Ra,Rbrbt_rel"
    " (bk1,bk1')Ra; (bl,bl')Ra,Rbrbt_rel; (bk,bk')Ra;
      (bv,bv')Rb; (br,br')Ra,Rbrbt_rel 
      (ord.rbt_del_from_right less bk1 bl bk bv br, 
      ord.rbt_del_from_right less' bk1' bl' bk' bv' br') 
     Ra,Rbrbt_rel"
    " (ck,ck')Ra; (ct,ct')Ra,Rbrbt_rel  
       (ord.rbt_del less ck ct, ord.rbt_del less' ck' ct')  Ra,Rbrbt_rel"
    apply (induct 
      ak1' al' ak' av' ar' and bk1' bl' bk' bv' br' and ck' ct'
      arbitrary: ak1 al ak av ar and bk1 bl bk bv br and ck ct
      rule: ord.rbt_del_from_left_rbt_del_from_right_rbt_del.induct)
    (* TODO/FIXME: We do not have 'deep' elimination rules, thus
      we have to do some ughly hack to apply the rbt_rel-elimination inside
      the induction hypothesis. *)
    apply (assumption
      | elim rbt_rel_elims color_rel_elims 
      | simp (no_asm_use) only: rbt_del.simps ord.rbt_del.simps
          rbt_del_from_left.simps ord.rbt_del_from_left.simps
          rbt_del_from_right.simps ord.rbt_del_from_right.simps
      | parametricity
      | rule rbt_rel_intros
      | hypsubst
      | (simp, rule ih_aux1, rprems)
      | (rule is_eq, simp)
    ) +
    done

  lemma param_rbt_del[param]:
    fixes less
    assumes param_less: "(less,less')  Ra  Ra  Id"
    shows
    "(ord.rbt_del_from_left less, ord.rbt_del_from_left less')  
      Ra  Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
    "(ord.rbt_del_from_right less, ord.rbt_del_from_right less') 
      Ra  Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
    "(ord.rbt_del less,ord.rbt_del less')  
      Ra  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
    by (intro fun_relI, blast intro: param_rbt_del_aux[OF param_less])+

  lemma param_rbt_delete[param]:
    fixes less
    assumes param_less[param]: "(less,less')  Ra  Ra  Id"
    shows "(ord.rbt_delete less, ord.rbt_delete less') 
       Ra  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
    unfolding rbt_delete_def[abs_def] ord.rbt_delete_def[abs_def]
    by parametricity

  term ord.rbt_insert_with_key

  abbreviation compare_rel :: "(RBT_Impl.compare × _) set" 
    where "compare_rel  Id"

  lemma param_compare[param]:
    "(RBT_Impl.LT,RBT_Impl.LT)compare_rel"
    "(RBT_Impl.GT,RBT_Impl.GT)compare_rel"
    "(RBT_Impl.EQ,RBT_Impl.EQ)compare_rel"
    "(RBT_Impl.case_compare,RBT_Impl.case_compare)RRRcompare_relR"
    by (auto split: RBT_Impl.compare.split)

  lemma param_rbtreeify_aux[param]:
    "nlength kvs; (n,n')nat_rel; (kvs,kvs')Ra,Rbprod_rellist_rel 
     (rbtreeify_f n kvs,rbtreeify_f n' kvs')
       Ra,Rbrbt_rel, Ra,Rbprod_rellist_relprod_rel"
    "nSuc (length kvs); (n,n')nat_rel; (kvs,kvs')Ra,Rbprod_rellist_rel
     (rbtreeify_g n kvs,rbtreeify_g n' kvs')
       Ra,Rbrbt_rel, Ra,Rbprod_rellist_relprod_rel"
    apply (induct n kvs and n kvs 
      arbitrary: n' kvs' and n' kvs'
      rule: rbtreeify_induct)

    (* TODO: Still requires some manual proof! *)
    apply (simp only: pair_in_Id_conv)
    apply (simp (no_asm_use) only: rbtreeify_f_simps rbtreeify_g_simps)
    apply parametricity

    apply (elim list_relE prod_relE)
    apply (simp only: pair_in_Id_conv)
    apply hypsubst
    apply (simp (no_asm_use) only: rbtreeify_f_simps rbtreeify_g_simps)
    apply parametricity

    apply clarsimp
    apply (subgoal_tac "(rbtreeify_f n kvs, rbtreeify_f n kvs'a) 
       Ra, Rbrbt_rel, Ra, Rbprod_rellist_relprod_rel")
    apply (clarsimp elim!: list_relE prod_relE)
    apply parametricity
    apply (rule refl)
    apply rprems
    apply (rule refl)
    apply assumption

    apply clarsimp
    apply (subgoal_tac "(rbtreeify_f n kvs, rbtreeify_f n kvs'a) 
       Ra, Rbrbt_rel, Ra, Rbprod_rellist_relprod_rel")
    apply (clarsimp elim!: list_relE prod_relE)
    apply parametricity
    apply (rule refl)
    apply rprems
    apply (rule refl)
    apply assumption

    apply simp
    apply parametricity

    apply clarsimp
    apply parametricity

    apply clarsimp
    apply (subgoal_tac "(rbtreeify_g n kvs, rbtreeify_g n kvs'a) 
       Ra, Rbrbt_rel, Ra, Rbprod_rellist_relprod_rel")
    apply (clarsimp elim!: list_relE prod_relE)
    apply parametricity
    apply (rule refl)
    apply parametricity
    apply (rule refl)

    apply clarsimp
    apply (subgoal_tac "(rbtreeify_f n kvs, rbtreeify_f n kvs'a) 
       Ra, Rbrbt_rel, Ra, Rbprod_rellist_relprod_rel")
    apply (clarsimp elim!: list_relE prod_relE)
    apply parametricity
    apply (rule refl)
    apply parametricity
    apply (rule refl)
    done    

  lemma param_rbtreeify[param]:
    "(rbtreeify, rbtreeify)  Ra,Rbprod_rellist_rel  Ra,Rbrbt_rel"
    unfolding rbtreeify_def[abs_def]
    apply parametricity
    by simp

  lemma param_sunion_with[param]:
    fixes less
    shows " (less,less')  Ra  Ra  Id; 
      (f,f')(RaRbRbRb); (a,a')Ra,Rbprod_rellist_rel;
      (b,b')Ra,Rbprod_rellist_rel  
     (ord.sunion_with less f a b, ord.sunion_with less' f' a' b')  
      Ra,Rbprod_rellist_rel"
    apply (induct f' a' b' arbitrary: f a b 
      rule: ord.sunion_with.induct[of less'])
    apply (elim_all list_relE prod_relE)
    apply (simp_all only: ord.sunion_with.simps)
    apply parametricity
    apply simp_all
    done

  lemma skip_red_alt:
    "RBT_Impl.skip_red t = (case t of 
      (Branch color.R l k v r)  l
    | _  t)"
    by (auto split: rbt.split color.split)

  function compare_height :: 
    "('a, 'b) RBT_Impl.rbt  ('a, 'b) RBT_Impl.rbt  ('a, 'b) RBT_Impl.rbt  ('a, 'b) RBT_Impl.rbt  RBT_Impl.compare"
    where
    "compare_height sx s t tx =
  (case (RBT_Impl.skip_red sx, RBT_Impl.skip_red s, RBT_Impl.skip_red t, RBT_Impl.skip_red tx) of
     (Branch _ sx' _ _ _, Branch _ s' _ _ _, Branch _ t' _ _ _, Branch _ tx' _ _ _)  
       compare_height (RBT_Impl.skip_black sx') s' t' (RBT_Impl.skip_black tx')
   | (_, rbt.Empty, _, Branch _ _ _ _ _)  RBT_Impl.LT
   | (Branch _ _ _ _ _, _, rbt.Empty, _)  RBT_Impl.GT
   | (Branch _ sx' _ _ _, Branch _ s' _ _ _, Branch _ t' _ _ _, rbt.Empty) 
       compare_height (RBT_Impl.skip_black sx') s' t' rbt.Empty
   | (rbt.Empty, Branch _ s' _ _ _, Branch _ t' _ _ _, Branch _ tx' _ _ _) 
       compare_height rbt.Empty s' t' (RBT_Impl.skip_black tx')
   | _  RBT_Impl.EQ)"
    by pat_completeness auto

  lemma skip_red_size: "size (RBT_Impl.skip_red b)  size b"
    by (auto simp add: skip_red_alt split: rbt.split color.split)

  lemma skip_black_size: "size (RBT_Impl.skip_black b)  size b"
    unfolding RBT_Impl.skip_black_def
    apply (auto 
      simp add: Let_def 
      split: rbt.split color.split
    )
    using skip_red_size[of b]
    apply auto
    done
    
  termination 
  proof -
    {
      fix s t x
      assume A: "s = RBT_Impl.skip_red t"
        and B: "x < size s"
      note B
      also note A
      also note skip_red_size
      finally have "x < size t" .
    } note AUX=this

    show "All compare_height_dom"
      apply (relation 
        "measure (λ(a, b, c, d). size a + size b + size c + size d)")
      apply rule

      (* FIXME: This is solved by
        apply (smt rbt.size(4) skip_black_size skip_red_size)+
        which is, however, not allowed for afp.
        *)

      apply (clarsimp simp: Let_def split: rbt.splits color.splits)
      apply (intro add_less_mono trans_less_add2 
        order_le_less_trans[OF skip_black_size], (erule AUX, simp)+) []

      apply (clarsimp simp: Let_def split: rbt.splits color.splits)
      apply (rule trans_less_add1)
      apply (intro add_less_mono trans_less_add2 
        order_le_less_trans[OF skip_black_size], (erule AUX, simp)+) []

      apply (clarsimp simp: Let_def split: rbt.splits color.splits)
      apply (intro add_less_mono trans_less_add2 
        order_le_less_trans[OF skip_black_size], (erule AUX, simp)+) []
      done
  qed

  lemmas [simp del] = compare_height.simps

  lemma compare_height_alt: 
    "RBT_Impl.compare_height sx s t tx = compare_height sx s t tx"
    apply (induct sx s t tx rule: compare_height.induct)
    apply (subst RBT_Impl.compare_height.simps)
    apply (subst compare_height.simps)
    apply (auto split: rbt.split)
    done

  term RBT_Impl.skip_red
  lemma param_skip_red[param]: "(RBT_Impl.skip_red,RBT_Impl.skip_red) 
     Rk,Rvrbt_rel  Rk,Rvrbt_rel"
    unfolding skip_red_alt[abs_def] by parametricity

  lemma param_skip_black[param]: "(RBT_Impl.skip_black,RBT_Impl.skip_black) 
     Rk,Rvrbt_rel  Rk,Rvrbt_rel"
    unfolding RBT_Impl.skip_black_def[abs_def] by parametricity

  term case_rbt
  lemma param_case_rbt':
    assumes "(t,t')Rk,Rvrbt_rel"
    assumes "t=rbt.Empty; t'=rbt.Empty  (fl,fl')R"
    assumes "c l k v r c' l' k' v' r'.  
      t = Branch c l k v r; t' = Branch c' l' k' v' r'; 
      (c,c')color_rel;
      (l,l')Rk,Rvrbt_rel; (k,k')Rk; (v,v')Rv; (r,r')Rk,Rvrbt_rel
      (fb c l k v r, fb' c' l' k' v' r')  R"
    shows "(case_rbt fl fb t, case_rbt fl' fb' t')  R"
    using assms by (auto split: rbt.split elim: rbt_rel_elims)
      
  lemma compare_height_param_aux[param]:
    " (sx,sx')Rk,Rvrbt_rel; (s,s')Rk,Rvrbt_rel;
       (t,t')Rk,Rvrbt_rel; (tx,tx')Rk,Rvrbt_rel 
     (compare_height sx s t tx, compare_height sx' s' t' tx')  compare_rel"
    apply (induct sx' s' t' tx' arbitrary: sx s t tx 
      rule: compare_height.induct)
    apply (subst (2) compare_height.simps)
    apply (subst compare_height.simps)
    apply (parametricity add: param_case_prod' param_case_rbt', (simp only: prod.inject)+) []
    done

  lemma compare_height_param[param]:
    "(RBT_Impl.compare_height,RBT_Impl.compare_height)  
      Rk,Rvrbt_rel  Rk,Rvrbt_rel  Rk,Rvrbt_rel  Rk,Rvrbt_rel 
       compare_rel"
    unfolding compare_height_alt[abs_def]
    by parametricity

lemma rbt_rel_bheight: "(t, t')  Ra, Rbrbt_rel  bheight t = bheight t'"
  by (induction t arbitrary: t') (auto elim!: rbt_rel_elims color_rel.cases)

lemma param_rbt_baliL[param]: "(rbt_baliL,rbt_baliL)  Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
proof (intro fun_relI, goal_cases)
  case (1 l l' a a' b b' r r')
  thus ?case
    apply (induct l a b r arbitrary: l' a' b' r' rule: rbt_baliL.induct)
    apply (elim_all rbt_rel_elims color_rel_elims)
    apply (simp_all only: rbt_baliL.simps)
    apply parametricity+
    done
qed

lemma param_rbt_baliR[param]: "(rbt_baliR,rbt_baliR)  Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
proof (intro fun_relI, goal_cases)
  case (1 l l' a a' b b' r r')
  thus ?case
    apply (induction l a b r arbitrary: l' a' b' r' rule: rbt_baliR.induct)
    apply (elim_all rbt_rel_elims color_rel_elims)
    apply (simp_all only: rbt_baliR.simps)
    apply parametricity+
    done
qed

lemma param_rbt_joinL[param]: "(rbt_joinL,rbt_joinL)  Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
proof (intro fun_relI, goal_cases)
  case (1 l l' a a' b b' r r')
  thus ?case
  proof (induction l a b r arbitrary: l' a' b' r' rule: rbt_joinL.induct)
    case (1 l a b r)
    have "bheight l < bheight r  r = RBT_Impl.MB ll k v rr  (ll, ll')  Ra, Rbrbt_rel 
       (k, k')  Ra  (v, v')  Rb  (rr, rr')  Ra, Rbrbt_rel 
       (rbt_baliL (rbt_joinL l a b ll) k v rr, rbt_baliL (rbt_joinL l' a' b' ll') k' v' rr')  Ra, Rbrbt_rel"
      for ll ll' k k' v v' rr rr'
      by parametricity (auto intro: 1)
    then show ?case
      using 1
      by (auto simp: rbt_joinL.simps[of l a b r] rbt_joinL.simps[of l' a' b' r'] rbt_rel_bheight
          intro: rbt_rel_intros color_rel.intros elim!: rbt_rel_elims color_rel_elims
          split: rbt.splits color.splits)
  qed
qed

lemma param_rbt_joinR[param]:
  "(rbt_joinR,rbt_joinR)  Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
proof (intro fun_relI, goal_cases)
  case (1 l l' a a' b b' r r')
  thus ?case
  proof (induction l a b r arbitrary: l' a' b' r' rule: rbt_joinR.induct)
    case (1 l a b r)
    have "bheight r < bheight l  l = RBT_Impl.MB ll k v rr  (ll, ll')  Ra, Rbrbt_rel 
       (k, k')  Ra  (v, v')  Rb  (rr, rr')  Ra, Rbrbt_rel 
       (rbt_baliR ll k v (rbt_joinR rr a b r), rbt_baliR ll' k' v' (rbt_joinR rr' a' b' r'))  Ra, Rbrbt_rel"
      for ll ll' k k' v v' rr rr'
      by parametricity (auto intro: 1)
    then show ?case
      using 1
      by (auto simp: rbt_joinR.simps[of l] rbt_joinR.simps[of l'] rbt_rel_bheight[symmetric]
          intro: rbt_rel_intros color_rel.intros elim!: rbt_rel_elims color_rel_elims
          split: rbt.splits color.splits)
  qed
qed

lemma param_rbt_join[param]: "(rbt_join,rbt_join)  Ra,Rbrbt_rel  Ra  Rb  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
  by (auto simp: rbt_join_def Let_def rbt_rel_bheight) parametricity+

lemma param_split[param]:
  fixes less
  assumes [param]: "(less,less')  Ra  Ra  Id"
  shows "(ord.rbt_split less, ord.rbt_split less')  Ra,Rbrbt_rel  Ra  Ra,Rbrbt_rel,Rboption_rel,Ra,Rbrbt_relprod_relprod_rel"
proof (intro fun_relI)
  fix t t' a a'
  assume "(t, t')  Ra, Rbrbt_rel" "(a, a')  Ra"
  then show "(ord.rbt_split less t a, ord.rbt_split less' t' a')  Ra,Rbrbt_rel,Rboption_rel,Ra,Rbrbt_relprod_relprod_rel"
  proof (induction t a arbitrary: t' rule: ord.rbt_split.induct[where ?less=less])
    case (2 c l k b r a)
    obtain c' l' k' b' r' where t'_def: "t' = Branch c' l' k' b' r'"
      using 2(3)
      by (auto elim: rbt_rel_elims)
    have sub_rel: "(l, l')  Ra, Rbrbt_rel" "(k, k')  Ra" "(b, b')  Rb" "(r, r')  Ra, Rbrbt_rel"
      using 2(3)
      by (auto simp: t'_def elim: rbt_rel_elims)
    have less_iff: "less a k  less' a' k'" "less k a  less' k' a'"
      using assms 2(4) sub_rel(2)
      by (auto dest: fun_relD)
    show ?case
      using 2(1)[OF _ sub_rel(1) 2(4)] 2(2)[OF _ _ sub_rel(4) 2(4)] sub_rel
      unfolding t'_def less_iff ord.rbt_split.simps(2)[of less c] ord.rbt_split.simps(2)[of less' c']
      by (auto split: prod.splits) parametricity+
  qed (auto simp: ord.rbt_split.simps elim!: rbt_rel_elims intro: rbt_rel_intros)
qed

lemma param_rbt_union_swap_rec[param]:
  fixes less
  assumes [param]: "(less,less')  Ra  Ra  Id"
  shows "(ord.rbt_union_swap_rec less, ord.rbt_union_swap_rec less') 
    (Ra  Rb  Rb  Rb)  Id  Ra,Rbrbt_rel  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
proof (intro fun_relI)
  fix f f' b b' t1 t1' t2 t2'
  assume "(f, f')  Ra  Rb  Rb  Rb" "(b, b')  bool_rel" "(t1, t1')  Ra, Rbrbt_rel" "(t2, t2')  Ra, Rbrbt_rel"
  then show "(ord.rbt_union_swap_rec less f b t1 t2, ord.rbt_union_swap_rec less' f' b' t1' t2')  Ra, Rbrbt_rel"
  proof (induction f b t1 t2 arbitrary: b' t1' t2' rule: ord.rbt_union_swap_rec.induct[where ?less=less])
    case (1 f b t1 t2)
    obtain γ s1 s2 where flip1: "(γ, s2, s1) =
      (if flip_rbt t2 t1 then (¬b, t1, t2) else (b, t2, t1))"
      by fastforce
    obtain γ' s1' s2' where flip2: "(γ', s2', s1') =
      (if flip_rbt t2' t1' then (¬b', t1', t2') else (b', t2', t1'))"
      by fastforce
    define g where "g = (if γ then λk v v'. f k v' v else f)"
    define g' where "g' = (if γ' then λk v v'. f' k v' v else f')"
    note bheight_cong = rbt_rel_bheight[OF 1(5)] rbt_rel_bheight[OF 1(6)]
    have flip_cong: "flip_rbt t2 t1  flip_rbt t2' t1'"
      by (auto simp: flip_rbt_def bheight_cong)
    have gamma_cong: "γ = γ'"
      using flip1 flip2 1(4)
      by (auto simp: flip_cong split: if_splits)
    have small_rbt_cong: "small_rbt s2  small_rbt s2'"
      using flip1 flip2
      by (auto simp: small_rbt_def flip_cong bheight_cong split: if_splits)
    have rbt_rel_s: "(s1, s1')  Ra, Rbrbt_rel" "(s2, s2')  Ra, Rbrbt_rel"
      using flip1 flip2 1(5,6)
      by (auto simp: flip_cong split: if_splits)
    have fun_rel_g: "(g, g')  Ra  Rb  Rb  Rb"
      using flip1 flip2 1(3,4)
      by (auto simp: flip_cong g_def g'_def intro: fun_relD[OF fun_relD[OF fun_relD]] split: if_splits)
    have rbt_rel_fold: "(RBT_Impl.fold (ord.rbt_insert_with_key less g) s2 s1, RBT_Impl.fold (ord.rbt_insert_with_key less' g') s2' s1')  Ra, Rbrbt_rel"
      unfolding RBT_Impl.fold_def RBT_Impl.entries_def ord.rbt_insert_with_key_def
      using rbt_rel_s fun_rel_g
      by parametricity
    {
      fix c l k v r c' l' k' v' r' ll β rr ll' β' rr'
      assume defs: "s1 = Branch c l k v r" "s1' = Branch c' l' k' v' r'"
        "ord.rbt_split less s2 k = (ll, β, rr)" "ord.rbt_split less' s2' k' = (ll', β', rr')"
        "¬small_rbt s2"
      have split_rel: "(ord.rbt_split less s2 k, ord.rbt_split less' s2' k')  Ra,Rbrbt_rel,Rboption_rel,Ra,Rbrbt_relprod_relprod_rel"
        using defs(1,2) param_split[OF assms, of Rb] rbt_rel_s
        by (auto elim: rbt_rel_elims dest: fun_relD)
      have IH1: "(ord.rbt_union_swap_rec less f γ l ll, ord.rbt_union_swap_rec less' f' γ' l' ll')  Ra,Rbrbt_rel"
        apply (rule 1(1)[OF refl flip1 refl refl _ _ _ refl])
        using 1(3) split_rel rbt_rel_s(1) defs
        by (auto simp: gamma_cong elim: rbt_rel_elims)
      have IH2: "(ord.rbt_union_swap_rec less f γ r rr, ord.rbt_union_swap_rec less' f' γ' r' rr')  Ra,Rbrbt_rel"
        apply (rule 1(2)[OF refl flip1 refl refl _ _ _ refl])
        using 1(3) split_rel rbt_rel_s(1) defs
        by (auto simp: gamma_cong elim: rbt_rel_elims)
      have fun_rel_g_app: "(g k v, g' k' v')  Rb  Rb"
        using fun_rel_g rbt_rel_s
        by (auto simp: defs elim: rbt_rel_elims dest: fun_relD)
      have "(rbt_join (ord.rbt_union_swap_rec less f γ l ll) k (case β of None  v | Some x  g k v x) (ord.rbt_union_swap_rec less f γ r rr),
      rbt_join (ord.rbt_union_swap_rec less' f' γ' l' ll') k' (case β' of None  v' | Some x  g' k' v' x) (ord.rbt_union_swap_rec less' f' γ' r' rr'))  Ra, Rbrbt_rel"
        apply parametricity
        using IH1 IH2 rbt_rel_s fun_rel_g_app split_rel
        by (auto simp: defs elim!: rbt_rel_elims)
    }
    then show ?case
      unfolding ord.rbt_union_swap_rec.simps[of _ _ _ t1] ord.rbt_union_swap_rec.simps[of _ _ _ t1']
      using rbt_rel_fold rbt_rel_s
      by (auto simp: flip1[symmetric] flip2[symmetric] g_def[symmetric] g'_def[symmetric] small_rbt_cong
          split: rbt.splits prod.splits elim: rbt_rel_elims)
  qed
qed

  lemma param_rbt_union[param]:
    fixes less
    assumes param_less[param]: "(less,less')  Ra  Ra  Id"
    shows "(ord.rbt_union less, ord.rbt_union less') 
       Ra,Rbrbt_rel  Ra,Rbrbt_rel  Ra,Rbrbt_rel"
    unfolding ord.rbt_union_def[abs_def] ord.rbt_union_with_key_def[abs_def]
    by parametricity

term rm_iterateoi
lemma param_rm_iterateoi[param]: "(rm_iterateoi,rm_iterateoi) 
   Ra,Rbrbt_rel  (RcId)  (Ra,Rbprod_rel  Rc  Rc)  Rc  Rc"
  unfolding rm_iterateoi_def
  by (parametricity)

lemma param_rm_reverse_iterateoi[param]: 
  "(rm_reverse_iterateoi,rm_reverse_iterateoi) 
     Ra,Rbrbt_rel  (RcId)  (Ra,Rbprod_rel  Rc  Rc)  Rc  Rc"
  unfolding rm_reverse_iterateoi_def
  by (parametricity)


lemma param_color_eq[param]: 
  "((=), (=))color_relcolor_relId"
  by (auto elim: color_rel.cases)

lemma param_color_of[param]: 
  "(color_of, color_of)Rk,Rvrbt_relcolor_rel"
  unfolding color_of_def
  by parametricity

term bheight
lemma param_bheight[param]:
  "(bheight,bheight)Rk,Rvrbt_relId"
  unfolding bheight_def
  by (parametricity)

lemma inv1_param[param]: "(inv1,inv1)Rk,Rvrbt_relId"
  unfolding inv1_def
  by (parametricity)

lemma inv2_param[param]: "(inv2,inv2)Rk,Rvrbt_relId"
  unfolding inv2_def
  by (parametricity)

term ord.rbt_less
lemma rbt_less_param[param]: "(ord.rbt_less,ord.rbt_less)  
  (RkRkId)  Rk  Rk,Rvrbt_rel  Id"
  unfolding ord.rbt_less_prop[abs_def]
  apply (parametricity add: param_list_ball)
  unfolding RBT_Impl.keys_def RBT_Impl.entries_def
  apply (parametricity)
  done

term ord.rbt_greater
lemma rbt_greater_param[param]: "(ord.rbt_greater,ord.rbt_greater)  
  (RkRkId)  Rk  Rk,Rvrbt_rel  Id"
  unfolding ord.rbt_greater_prop[abs_def]
  apply (parametricity add: param_list_ball)
  unfolding RBT_Impl.keys_def RBT_Impl.entries_def
  apply (parametricity)
  done

lemma rbt_sorted_param[param]:
  "(ord.rbt_sorted,ord.rbt_sorted)(RkRkId)Rk,Rvrbt_relId"
  unfolding ord.rbt_sorted_def[abs_def]
  by (parametricity)

lemma is_rbt_param[param]: "(ord.is_rbt,ord.is_rbt)  
  (RkRkId)  Rk,Rvrbt_rel  Id"
  unfolding ord.is_rbt_def[abs_def]
  by (parametricity)

definition "rbt_map_rel' lt = br (ord.rbt_lookup lt) (ord.is_rbt lt)"

lemma (in linorder) rbt_map_impl:
  "(rbt.Empty,Map.empty)  rbt_map_rel' (<)"
  "(rbt_insert,λk v m. m(kv)) 
     Id  Id  rbt_map_rel' (<)  rbt_map_rel' (<)"
  "(rbt_lookup,λm k. m k)  rbt_map_rel' (<)  Id  Idoption_rel"
  "(rbt_delete,λk m. m|`(-{k}))  Id  rbt_map_rel' (<)  rbt_map_rel' (<)"
  "(rbt_union,(++)) 
     rbt_map_rel' (<)  rbt_map_rel' (<)  rbt_map_rel' (<)"
  by (auto simp add: 
    rbt_lookup_rbt_insert rbt_lookup_rbt_delete rbt_lookup_rbt_union
    rbt_union_is_rbt
    rbt_map_rel'_def br_def)

lemma sorted_wrt_keys_true[simp]: "sorted_wrt (λ(_,_) (_,_). True) l"
  apply (induct l)
  apply auto
  done

(*
lemma (in linorder) rbt_it_linord_impl: 
  "is_map_iterator_linord (rbt_map_rel' (<)) Id Id Id 
    (rm_iterateoi::_ ⇒ ('a,'v,'s) map_iterator)"
  unfolding is_map_iterator_genord_def is_map_iterator_linord_def 
    gen_map_iterator_genord_def[abs_def]
  apply (intro fun_relI)
  apply (clarsimp intro!: chooseR.intros[OF _ IdI])
proof -
  case (goal1 t s' c f s)
  hence "is_rbt t" and [simp]: "s'=(rbt_lookup t)" 
    unfolding rbt_map_rel'_def br_def by simp_all
  hence RSORTED: "rbt_sorted t" by (simp add: is_rbt_def)
 
  thm rm_iterateoi_correct
  from rm_iterateoi_correct[OF RSORTED,
    unfolded set_iterator_map_linord_def
      set_iterator_genord_def
  ] obtain l where 
      "distinct l" 
      and "map_to_set (rbt_lookup t) = set l"
      and "sorted_wrt (λ(k,_) (k',_). k ≤ k') l"
      and "(rm_iterateoi t::('a,'v,'s) map_iterator) = foldli l"
    by blast
  thus ?case 
    apply (rule_tac exI[where x=l])
    apply (simp add: sorted_wrt_keys_map_fst)
    by (metis iterate_to_list_foldli map_iterator_foldli_conv rev_rev_ident 
      set_iterator_foldli_correct)
qed

lemma (in linorder) rbt_it_rev_linord_impl: 
  "is_map_iterator_rev_linord (rbt_map_rel' (<)) Id Id Id 
    (rm_reverse_iterateoi::_ ⇒ ('a,'v,'s) map_iterator)"
  unfolding is_map_iterator_genord_def is_map_iterator_rev_linord_def 
    gen_map_iterator_genord_def[abs_def]
  apply (intro fun_relI)
  apply (clarsimp intro!: chooseR.intros[OF _ IdI])
proof -
  case (goal1 t s' c f s)
  hence "is_rbt t" and [simp]: "s'=(rbt_lookup t)" 
    unfolding rbt_map_rel'_def br_def by simp_all
  hence RSORTED: "rbt_sorted t" by (simp add: is_rbt_def)
  
  from rm_reverse_iterateoi_correct[unfolded 
    set_iterator_map_rev_linord_def
    set_iterator_genord_def,
    OF RSORTED
  ] obtain l where 
      "distinct l" 
      and "map_to_set (rbt_lookup t) = set l"
      and "sorted_wrt (λ(k,_) (k',_). k ≥ k') l"
      and "(rm_reverse_iterateoi t::('a,'v,'s) map_iterator) = foldli l"
    by blast
  thus ?case 
    apply (rule_tac exI[where x=l])
    apply (simp add: sorted_wrt_keys_map_fst)
    by (metis iterate_to_list_foldli map_iterator_foldli_conv rev_rev_ident 
      set_iterator_foldli_correct)
qed

lemma (in linorder) rbt_it_impl: 
  "is_map_iterator (rbt_map_rel' (<)) Id Id Id rm_iterateoi"
  unfolding is_map_iterator_def 
  apply (rule is_map_iterator_genord_weaken)
  apply (rule rbt_it_linord_impl[unfolded is_map_iterator_linord_def])
  ..

*)

definition rbt_map_rel_def_internal:
  "rbt_map_rel lt Rk Rv  Rk,Rvrbt_rel O rbt_map_rel' lt"

lemma rbt_map_rel_def: 
  "Rk,Rvrbt_map_rel lt  Rk,Rvrbt_rel O rbt_map_rel' lt"
  by (simp add: rbt_map_rel_def_internal relAPP_def)

(*
lemma (in linorder) autoref_gen_rbt_iterate_linord:
  "is_map_iterator_linord 
    (⟨Rk,Rv⟩rbt_map_rel (<)) (Rk::(_×'a) set) Rv Rσ rm_iterateoi"
proof -
  note param_rm_iterateoi[of Rk Rv Rσ]
  also note rbt_it_linord_impl[
    unfolded is_map_iterator_linord_def is_map_iterator_genord_def]
  finally (relcompI) show ?thesis
    unfolding is_map_iterator_linord_def is_map_iterator_genord_def
    apply -
    apply (erule rev_subsetD)
    apply (simp add: rbt_map_rel_def rbt_map_rel'_def)
    apply (
      rule Orderings.order_trans[OF fun_rel_comp_dist] fun_rel_mono subset_refl
      | simp
    )+
    done
qed

lemma (in linorder) autoref_gen_rbt_iterate_rev_linord:
  "is_map_iterator_rev_linord 
    (⟨Rk,Rv⟩rbt_map_rel (<)) (Rk::(_×'a) set) Rv Rσ rm_reverse_iterateoi"
proof -
  note param_rm_reverse_iterateoi[of Rk Rv Rσ]
  also note rbt_it_rev_linord_impl[
    unfolded is_map_iterator_rev_linord_def is_map_iterator_genord_def]
  finally (relcompI) show ?thesis
    unfolding is_map_iterator_rev_linord_def is_map_iterator_genord_def
    apply -
    apply (erule rev_subsetD)
    apply (simp add: rbt_map_rel_def rbt_map_rel'_def)
    apply (
      rule Orderings.order_trans[OF fun_rel_comp_dist] fun_rel_mono subset_refl
      | simp
    )+
    done
qed

lemma (in linorder) autoref_gen_rbt_iterate:
  "is_map_iterator 
    (⟨Rk,Rv⟩rbt_map_rel (<)) (Rk::(_×'a) set) Rv Rσ rm_iterateoi"
proof -
  note param_rm_iterateoi[of Rk Rv Rσ]
  also note rbt_it_impl[
    unfolded is_map_iterator_def is_map_iterator_genord_def]
  finally (relcompI) show ?thesis
    unfolding is_map_iterator_def is_map_iterator_genord_def
    apply -
    apply (erule rev_subsetD)
    apply (simp add: rbt_map_rel_def rbt_map_rel'_def)
    apply (
      rule Orderings.order_trans[OF fun_rel_comp_dist] fun_rel_mono subset_refl
      | simp
    )+
    done
qed
*)

lemma (in linorder) autoref_gen_rbt_empty: 
  "(rbt.Empty,Map.empty)  Rk,Rvrbt_map_rel (<)"
  by (auto simp: rbt_map_rel_def 
    intro!: rbt_map_impl rbt_rel_intros)

lemma (in linorder) autoref_gen_rbt_insert:
  fixes less_impl
  assumes param_less: "(less_impl,(<))  Rk  Rk  Id"
  shows "(ord.rbt_insert less_impl,λk v m. m(kv))  
    Rk  Rv  Rk,Rvrbt_map_rel (<)  Rk,Rvrbt_map_rel (<)"
  apply (intro fun_relI)
  unfolding rbt_map_rel_def
  apply (auto intro!: relcomp.intros)
  apply (rule param_rbt_insert[OF param_less, param_fo])
  apply assumption+
  apply (rule rbt_map_impl[param_fo])
  apply (rule IdI | assumption)+
  done

lemma (in linorder) autoref_gen_rbt_lookup:
  fixes less_impl
  assumes param_less: "(less_impl,(<))  Rk  Rk  Id"
  shows "(ord.rbt_lookup less_impl, λm k. m k)  
    Rk,Rvrbt_map_rel (<)  Rk  Rvoption_rel"
  unfolding rbt_map_rel_def
  apply (intro fun_relI)
  apply (elim relcomp.cases)
  apply hypsubst
  apply (subst R_O_Id[symmetric])
  apply (rule relcompI)
  apply (rule param_rbt_lookup[OF param_less, param_fo])
  apply assumption+
  apply (subst option_rel_id_simp[symmetric])
  apply (rule rbt_map_impl[param_fo])
  apply assumption
  apply (rule IdI)
  done

lemma (in linorder) autoref_gen_rbt_delete:
  fixes less_impl
  assumes param_less: "(less_impl,(<))  Rk  Rk  Id"
  shows "(ord.rbt_delete less_impl, λk m. m |`(-{k}))  
    Rk  Rk,Rvrbt_map_rel (<)  Rk,Rvrbt_map_rel (<)"
  unfolding rbt_map_rel_def
  apply (intro fun_relI)
  apply (elim relcomp.cases)
  apply hypsubst
  apply (rule relcompI)
  apply (rule param_rbt_delete[OF param_less, param_fo])
  apply assumption+
  apply (rule rbt_map_impl[param_fo])
  apply (rule IdI)
  apply assumption
  done

lemma (in linorder) autoref_gen_rbt_union:
  fixes less_impl
  assumes param_less: "(less_impl,(<))  Rk  Rk  Id"
  shows "(ord.rbt_union less_impl, (++))  
    Rk,Rvrbt_map_rel (<)  Rk,Rvrbt_map_rel (<)  Rk,Rvrbt_map_rel (<)"
  unfolding rbt_map_rel_def
  apply (intro fun_relI)
  apply (elim relcomp.cases)
  apply hypsubst
  apply (rule relcompI)
  apply (rule param_rbt_union[OF param_less, param_fo])
  apply assumption+
  apply (rule rbt_map_impl[param_fo])
  apply assumption+
  done

subsection ‹A linear ordering on red-black trees›

abbreviation "rbt_to_list t  it_to_list rm_iterateoi t"

lemma (in linorder) rbt_to_list_correct: 
  assumes SORTED: "rbt_sorted t"
  shows "rbt_to_list t = sorted_list_of_map (rbt_lookup t)" (is "?tl = _")
proof -
  from map_it_to_list_linord_correct[where it=rm_iterateoi, OF 
    rm_iterateoi_correct[OF SORTED]
  ] have 
      M: "map_of ?tl = rbt_lookup t"
      and D: "distinct (map fst ?tl)"
      and S: "sorted (map fst ?tl)"
    by (simp_all)

  from the_sorted_list_of_map[OF D S] M show ?thesis
    by simp
qed

definition 
  "cmp_rbt cmpk cmpv  cmp_img rbt_to_list (cmp_lex (cmp_prod cmpk cmpv))"

lemma (in linorder) param_rbt_sorted_list_of_map[param]:
  shows "(rbt_to_list, sorted_list_of_map)  
  Rk, Rvrbt_map_rel (<)  Rk,Rvprod_rellist_rel"
  apply (auto simp: rbt_map_rel_def rbt_map_rel'_def br_def
    rbt_to_list_correct[symmetric]
  )
  by (parametricity)

lemma param_rbt_sorted_list_of_map'[param]:
  assumes ELO: "eq_linorder cmp'"
  shows "(rbt_to_list,linorder.sorted_list_of_map (comp2le cmp'))  
    Rk,Rvrbt_map_rel (comp2lt cmp')  Rk,Rvprod_rellist_rel"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    by parametricity
qed

lemma rbt_linorder_impl:
  assumes ELO: "eq_linorder cmp'"
  assumes [param]: "(cmp,cmp')RkRkId"
  shows 
  "(cmp_rbt cmp, cmp_map cmp')  
    (RvRvId) 
     Rk,Rvrbt_map_rel (comp2lt cmp') 
     Rk,Rvrbt_map_rel (comp2lt cmp')  Id"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)

  show ?thesis
    unfolding cmp_map_def[abs_def] cmp_rbt_def[abs_def]
    apply (parametricity add: param_cmp_extend param_cmp_img)
    unfolding rbt_map_rel_def[abs_def] rbt_map_rel'_def br_def
    by auto
qed

lemma color_rel_sv[relator_props]: "single_valued color_rel"
  by (auto intro!: single_valuedI elim: color_rel.cases)

lemma rbt_rel_sv_aux:
  assumes SK: "single_valued Rk" 
  assumes SV: "single_valued Rv"
  assumes I1: "(a,b)(Rk, Rvrbt_rel)"
  assumes I2: "(a,c)(Rk, Rvrbt_rel)"
  shows "b=c"
  using I1 I2
  apply (induct arbitrary: c)
  apply (elim rbt_rel_elims)
  apply simp
  apply (elim rbt_rel_elims)
  apply (simp add: single_valuedD[OF color_rel_sv] 
    single_valuedD[OF SK] single_valuedD[OF SV])
  done

lemma rbt_rel_sv[relator_props]:
  assumes SK: "single_valued Rk" 
  assumes SV: "single_valued Rv"
  shows "single_valued (Rk, Rvrbt_rel)"
  by (auto intro: single_valuedI rbt_rel_sv_aux[OF SK SV])

lemma rbt_map_rel_sv[relator_props]:
  "single_valued Rk; single_valued Rv 
   single_valued (Rk,Rvrbt_map_rel lt)"
  apply (auto simp: rbt_map_rel_def rbt_map_rel'_def)
  apply (rule single_valued_relcomp)
  apply (rule rbt_rel_sv, assumption+)
  apply (rule br_sv)
  done

lemmas [autoref_rel_intf] = REL_INTFI[of "rbt_map_rel x" i_map] for x


subsection ‹Second Part: Binding›
lemma autoref_rbt_empty[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (RkRkId)"
  shows "(rbt.Empty,op_map_empty)  
    Rk,Rvrbt_map_rel (comp2lt cmp')"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    by (simp) (rule autoref_gen_rbt_empty)
qed

lemma autoref_rbt_update[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (RkRkId)"
  shows "(ord.rbt_insert (comp2lt cmp),op_map_update)  
    RkRvRk,Rvrbt_map_rel (comp2lt cmp') 
     Rk,Rvrbt_map_rel (comp2lt cmp')"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    unfolding op_map_update_def[abs_def]
    apply (rule autoref_gen_rbt_insert)
    unfolding comp2lt_def[abs_def]
    by (parametricity)
qed

lemma autoref_rbt_lookup[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (RkRkId)"
  shows "(λk t. ord.rbt_lookup (comp2lt cmp) t k, op_map_lookup)  
    Rk  Rk,Rvrbt_map_rel (comp2lt cmp')  Rvoption_rel"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    unfolding op_map_lookup_def[abs_def]
    apply (intro fun_relI)
    apply (rule autoref_gen_rbt_lookup[param_fo])
    apply (unfold comp2lt_def[abs_def]) []
    apply (parametricity)
    apply assumption+
    done
qed

lemma autoref_rbt_delete[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (RkRkId)"
  shows "(ord.rbt_delete (comp2lt cmp),op_map_delete) 
    Rk  Rk,Rvrbt_map_rel (comp2lt cmp') 
        Rk,Rvrbt_map_rel (comp2lt cmp')"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    unfolding op_map_delete_def[abs_def]
    apply (intro fun_relI)
    apply (rule autoref_gen_rbt_delete[param_fo])
    apply (unfold comp2lt_def[abs_def]) []
    apply (parametricity)
    apply assumption+
    done
qed

lemma autoref_rbt_union[autoref_rules]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (RkRkId)"
  shows "(ord.rbt_union (comp2lt cmp),(++)) 
    Rk,Rvrbt_map_rel (comp2lt cmp')  Rk,Rvrbt_map_rel (comp2lt cmp')
        Rk,Rvrbt_map_rel (comp2lt cmp')"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    apply (intro fun_relI)
    apply (rule autoref_gen_rbt_union[param_fo])
    apply (unfold comp2lt_def[abs_def]) []
    apply (parametricity)
    apply assumption+
    done
qed

lemma autoref_rbt_is_iterator[autoref_ga_rules]: 
  assumes ELO: "GEN_ALGO_tag (eq_linorder cmp')"
  shows "is_map_to_sorted_list (comp2le cmp') Rk Rv (rbt_map_rel (comp2lt cmp'))
    rbt_to_list"
proof -
  interpret linorder "comp2le cmp'" "comp2lt cmp'"
    using ELO by (simp add: eq_linorder_class_conv)

  show ?thesis
    unfolding is_map_to_sorted_list_def
      it_to_sorted_list_def
    apply auto
  proof -
    fix r m'
    assume "(r, m')  Rk, Rvrbt_map_rel (comp2lt cmp')"
    then obtain r' where R1: "(r,r')Rk,Rvrbt_rel" 
      and R2: "(r',m')  rbt_map_rel' (comp2lt cmp')"
      unfolding rbt_map_rel_def by blast
    
    from R2 have "is_rbt r'" and M': "m' = rbt_lookup r'"
      unfolding rbt_map_rel'_def
      by (simp_all add: br_def)
    hence SORTED: "rbt_sorted r'"
      by (simp add: is_rbt_def)

    from map_it_to_list_linord_correct[where it = rm_iterateoi, OF 
      rm_iterateoi_correct[OF SORTED]
    ] have 
        M: "map_of (rbt_to_list r') = rbt_lookup r'"
        and D: "distinct (map fst (rbt_to_list r'))"
        and S: "sorted (map fst (rbt_to_list r'))"
      by (simp_all)

    show "l'. (rbt_to_list r, l')  Rk, Rvprod_rellist_rel 
            distinct l' 
            map_to_set m' = set l' 
            sorted_wrt (key_rel (comp2le cmp')) l'"
    proof (intro exI conjI)
      from D show "distinct (rbt_to_list r')" by (rule distinct_mapI)
      from S show "sorted_wrt (key_rel (comp2le cmp')) (rbt_to_list r')"
        unfolding key_rel_def[abs_def]
        by simp
      show "(rbt_to_list r, rbt_to_list r')  Rk, Rvprod_rellist_rel"
        by (parametricity add: R1)
      from M show "map_to_set m' = set (rbt_to_list r')"
        by (simp add: M' map_of_map_to_set[OF D])
    qed
  qed
qed
        
(* TODO: Reverse iterator *)

lemmas [autoref_ga_rules] = class_to_eq_linorder

lemma (in linorder) dflt_cmp_id:
  "(dflt_cmp (≤) (<), dflt_cmp (≤) (<))IdIdId"
  by auto

lemmas [autoref_rules] = dflt_cmp_id

lemma rbt_linorder_autoref[autoref_rules]:
  assumes "SIDE_GEN_ALGO (eq_linorder cmpk')"
  assumes "SIDE_GEN_ALGO (eq_linorder cmpv')"
  assumes "GEN_OP cmpk cmpk' (RkRkId)"
  assumes "GEN_OP cmpv cmpv' (RvRvId)"
  shows 
  "(cmp_rbt cmpk cmpv, cmp_map cmpk' cmpv')  
       Rk,Rvrbt_map_rel (comp2lt cmpk') 
     Rk,Rvrbt_map_rel (comp2lt cmpk')  Id"
  apply (intro fun_relI)
  apply (rule rbt_linorder_impl[param_fo])
  using assms 
  apply simp_all
  done

(* TODO: Move. This belongs to generic algorithms for orders *)
lemma map_linorder_impl[autoref_ga_rules]:
  assumes "GEN_ALGO_tag (eq_linorder cmpk)"
  assumes "GEN_ALGO_tag (eq_linorder cmpv)"
  shows "eq_linorder (cmp_map cmpk cmpv)"
  using assms apply simp_all
  using map_ord_eq_linorder .

lemma set_linorder_impl[autoref_ga_rules]:
  assumes "GEN_ALGO_tag (eq_linorder cmpk)"
  shows "eq_linorder (cmp_set cmpk)"
  using assms apply simp_all
  using set_ord_eq_linorder .

lemma (in linorder) rbt_map_rel_finite_aux:
  "finite_map_rel (Rk,Rvrbt_map_rel (<))"
  unfolding finite_map_rel_def
  by (auto simp: rbt_map_rel_def rbt_map_rel'_def br_def)

lemma rbt_map_rel_finite[relator_props]: 
  assumes ELO: "GEN_ALGO_tag (eq_linorder cmpk)"
  shows "finite_map_rel (Rk,Rvrbt_map_rel (comp2lt cmpk))"
proof -
  interpret linorder "comp2le cmpk" "comp2lt cmpk"
    using ELO by (simp add: eq_linorder_class_conv)
  show ?thesis
    using rbt_map_rel_finite_aux .
qed

abbreviation 
  "dflt_rm_rel  rbt_map_rel (comp2lt (dflt_cmp (≤) (<)))"

lemmas [autoref_post_simps] = dflt_cmp_inv2 dflt_cmp_2inv

lemma [simp,autoref_post_simps]: "ord.rbt_ins (<) = rbt_ins"
proof (intro ext, goal_cases)
  case (1 x xa xb xc) thus ?case
    apply (induct x xa xb xc rule: rbt_ins.induct)
    apply (simp_all add: ord.rbt_ins.simps)
    done
qed

lemma [autoref_post_simps]: "ord.rbt_lookup ((<)::_::linorder_) = rbt_lookup"
  unfolding ord.rbt_lookup_def rbt_lookup_def ..

lemma [simp,autoref_post_simps]:
  "ord.rbt_insert_with_key (<) = rbt_insert_with_key"
  "ord.rbt_insert (<) = rbt_insert"
  unfolding 
    ord.rbt_insert_with_key_def[abs_def] rbt_insert_with_key_def[abs_def]
    ord.rbt_insert_def[abs_def] rbt_insert_def[abs_def]
  by simp_all

(* TODO: Move, probably to some orderings setup theory *)
lemma autoref_comp2eq[autoref_rules_raw]:
  assumes PRIO_TAG_GEN_ALGO
  assumes ELC: "SIDE_GEN_ALGO (eq_linorder cmp')"
  assumes [simplified,param]: "GEN_OP cmp cmp' (RRId)"
  shows "(comp2eq cmp, (=))  RRId"
proof -
  from ELC have 1: "eq_linorder cmp'" by simp
  show ?thesis
    apply (subst eq_linorder_comp2eq_eq[OF 1,symmetric])
    by parametricity
qed

lemma pi'_rm[icf_proper_iteratorI]: 
  "proper_it' rm_iterateoi rm_iterateoi"
  "proper_it' rm_reverse_iterateoi rm_reverse_iterateoi"
  apply (rule proper_it'I)
  apply (rule pi_rm)
  apply (rule proper_it'I)
  apply (rule pi_rm_rev)
  done

declare pi'_rm[proper_it]


lemmas autoref_rbt_rules = 
  autoref_rbt_empty
  autoref_rbt_lookup
  autoref_rbt_update
  autoref_rbt_delete
  autoref_rbt_union

lemmas autoref_rbt_rules_linorder[autoref_rules_raw] = 
  autoref_rbt_rules[where Rk="Rk"] for Rk :: "(_×_::linorder) set"

end

Theory Impl_Cfun_Set

section ‹Set by Characteristic Function›
theory Impl_Cfun_Set
imports "../Intf/Intf_Set"
begin

definition fun_set_rel where
  fun_set_rel_internal_def: 
  "fun_set_rel R  (Rbool_rel) O br Collect (λ_. True)"

lemma fun_set_rel_def: "Rfun_set_rel = (Rbool_rel) O br Collect (λ_. True)"
  by (simp add: relAPP_def fun_set_rel_internal_def)

lemma fun_set_rel_sv[relator_props]: 
  "single_valued R; Range R = UNIV  single_valued (Rfun_set_rel)"
  unfolding fun_set_rel_def
  by (tagged_solver (keep))

lemma fun_set_rel_RUNIV[relator_props]:
  assumes SV: "single_valued R" 
  shows "Range (Rfun_set_rel) = UNIV"
proof -
  {
    fix b
    have "a. (a,b)Rfun_set_rel" unfolding fun_set_rel_def
      apply (rule exI)
      apply (rule relcompI)
    proof -
      show "((λx. xb),b)br Collect (λ_. True)" by (auto simp: br_def)
      show "(λx'. x. (x',x)R  xb,λx. x  b)R  bool_rel"
        by (auto dest: single_valuedD[OF SV])
    qed
  } thus ?thesis by blast
qed

lemmas [autoref_rel_intf] = REL_INTFI[of fun_set_rel i_set]

lemma fs_mem_refine[autoref_rules]: "(λx f. f x,(∈))  R  Rfun_set_rel  bool_rel"
  apply (intro fun_relI)
  apply (auto simp add: fun_set_rel_def br_def dest: fun_relD)
  done

lemma fun_set_Collect_refine[autoref_rules]: 
  "(λx. x, Collect)(Rbool_rel)  Rfun_set_rel"
  unfolding fun_set_rel_def
  by (auto simp: br_def)

lemma fun_set_empty_refine[autoref_rules]: 
  "(λ_. False,{})Rfun_set_rel"
  by (force simp add: fun_set_rel_def br_def)

lemma fun_set_UNIV_refine[autoref_rules]: 
  "(λ_. True,UNIV)Rfun_set_rel"
  by (force simp add: fun_set_rel_def br_def)

lemma fun_set_union_refine[autoref_rules]: 
  "(λa b x. a x  b x,(∪))Rfun_set_rel  Rfun_set_rel  Rfun_set_rel"
proof -
  have A: "a b. (λx. xa  xb, a  b)  br Collect (λ_. True)"
    by (auto simp: br_def)

  show ?thesis
    apply (simp add: fun_set_rel_def)
    apply (intro fun_relI)
    apply clarsimp
    apply rule
    defer
    apply (rule A)
    apply (auto simp: br_def dest: fun_relD)
    done
qed

lemma fun_set_inter_refine[autoref_rules]: 
  "(λa b x. a x  b x,(∩))Rfun_set_rel  Rfun_set_rel  Rfun_set_rel"
proof -
  have A: "a b. (λx. xa  xb, a  b)  br Collect (λ_. True)"
    by (auto simp: br_def)

  show ?thesis
    apply (simp add: fun_set_rel_def)
    apply (intro fun_relI)
    apply clarsimp
    apply rule
    defer
    apply (rule A)
    apply (auto simp: br_def dest: fun_relD)
    done
qed


lemma fun_set_diff_refine[autoref_rules]: 
  "(λa b x. a x  ¬b x,(-))Rfun_set_rel  Rfun_set_rel  Rfun_set_rel"
proof -
  have A: "a b. (λx. xa  ¬xb, a - b)  br Collect (λ_. True)"
    by (auto simp: br_def)

  show ?thesis
    apply (simp add: fun_set_rel_def)
    apply (intro fun_relI)
    apply clarsimp
    apply rule
    defer
    apply (rule A)
    apply (auto simp: br_def dest: fun_relD)
    done
qed



end

Theory Impl_Array_Map

section ‹\isaheader{Array-Based Maps with Natural Number Keys}›
theory Impl_Array_Map
imports 
  Automatic_Refinement.Automatic_Refinement
  "../../Lib/Diff_Array"
  "../../Iterator/Iterator"
  "../Gen/Gen_Map"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
begin

type_synonym 'v iam = "'v option array"

subsection ‹Definitions›

definition iam_α :: "'v iam  nat  'v" where
  "iam_α a i  if i < array_length a then array_get a i else None"

lemma [code]: "iam_α a i  array_get_oo None a i"
  unfolding array_get_oo_def iam_α_def .

abbreviation iam_invar :: "'v iam  bool" where "iam_invar  λ_. True"

definition iam_empty :: "unit  'v iam" 
  where "iam_empty  λ_::unit. array_of_list []"

definition iam_lookup :: "nat  'v iam  'v"
  where [code_unfold]: "iam_lookup k a  iam_α a k"

definition "iam_increment (l::nat) idx  
  max (idx + 1 - l) (2 * l + 3)"

lemma incr_correct: "¬ idx < l  idx < l + iam_increment l idx"
  unfolding iam_increment_def by auto

definition iam_update :: "nat  'v  'v iam  'v iam"
  where "iam_update k v a  let
    l = array_length a;
    a = if k < l then a else array_grow a (iam_increment l k) None
  in
    array_set a k (Some v)"

lemma [code]: "iam_update k v a  array_set_oo 
  (λ_. let l=array_length a in 
         array_set (array_grow a (iam_increment l k) None) k (Some v))
  a k (Some v)"
  unfolding iam_update_def array_set_oo_def
  apply (rule eq_reflection)
  by auto


definition iam_delete :: "nat  'v iam  'v iam"
  where "iam_delete k a  
  if k<array_length a then array_set a k None else a"

lemma [code]: "iam_delete k a  array_set_oo (λ_. a) a k None"
  unfolding iam_delete_def array_set_oo_def by auto

primrec iam_iteratei_aux 
  :: "nat  ('v iam)  (bool)  (nat × 'v)    " 
  where
    "iam_iteratei_aux 0 a c f σ = σ"
  | "iam_iteratei_aux (Suc i) a c f σ = (
      if c σ then   
        iam_iteratei_aux i a c f (
          case array_get a i of None  σ | Some x  f (i, x) σ
        )
      else σ)"

definition iam_iteratei :: "'v iam  (nat × 'v,) set_iterator" where 
  "iam_iteratei a = iam_iteratei_aux (array_length a) a"



subsection ‹Parametricity›

definition iam_rel_def_internal: 
  "iam_rel R  R option_rel array_rel"
lemma iam_rel_def: "R iam_rel = R option_rel array_rel"
    by (simp add: iam_rel_def_internal relAPP_def)

lemma iam_rel_sv[relator_props]:
  "single_valued Rv  single_valued (Rviam_rel)"
  unfolding iam_rel_def
  by tagged_solver

lemma param_iam_α[param]:
  "(iam_α, iam_α)  R iam_rel  nat_rel  R option_rel"
  unfolding iam_α_def[abs_def] iam_rel_def by parametricity

lemma param_iam_invar[param]:
  "(iam_invar, iam_invar)  R iam_rel  bool_rel"
  unfolding iam_rel_def by parametricity

lemma param_iam_empty[param]: 
  "(iam_empty, iam_empty)  unit_rel  Riam_rel"
    unfolding iam_empty_def[abs_def] iam_rel_def by parametricity

lemma param_iam_lookup[param]: 
  "(iam_lookup, iam_lookup)  nat_rel  Riam_rel  Roption_rel"
  unfolding iam_lookup_def[abs_def] 
  by parametricity

(* TODO: why does parametricity fail here? *)
lemma param_iam_increment[param]:
  "(iam_increment, iam_increment)  nat_rel  nat_rel  nat_rel"
  unfolding iam_increment_def[abs_def] 
  by simp

(* TODO: The builtin "Let" rule for parametricity does some unpleasant things
         here, leading to an unprovable subgoal. Investigate this. *)
lemma param_iam_update[param]:
  "(iam_update, iam_update)  nat_rel  R  Riam_rel  Riam_rel"
unfolding iam_update_def[abs_def] iam_rel_def Let_def
apply parametricity
done

lemma param_iam_delete[param]:
  "(iam_delete, iam_delete)  nat_rel  Riam_rel  Riam_rel"
  unfolding iam_delete_def[abs_def] iam_rel_def by parametricity 

lemma param_iam_iteratei_aux[param]:
  assumes I: "i  array_length a"
  assumes IR: "(i,i')  nat_rel"
  assumes AR: "(a,a')  Raiam_rel"
  assumes CR: "(c,c')  Rb  bool_rel"
  assumes FR: "(f,f')  nat_rel,Raprod_rel  Rb  Rb"
  assumes σR: "(σ,σ')  Rb"
  shows "(iam_iteratei_aux i a c f σ, iam_iteratei_aux i' a' c' f' σ')  Rb"
  using assms
  unfolding iam_rel_def
  apply (induct i' arbitrary: i σ σ')
  apply (simp_all only: pair_in_Id_conv iam_iteratei_aux.simps)
  apply parametricity
  apply simp_all
  done

lemma param_iam_iteratei[param]:
  "(iam_iteratei,iam_iteratei)  Raiam_rel  (Rb  bool_rel)  
      (nat_rel,Raprod_rel  Rb  Rb)  Rb  Rb"
  unfolding iam_iteratei_def[abs_def] 
  by parametricity (simp_all add: iam_rel_def)



subsection ‹Correctness›

definition "iam_rel'  br iam_α iam_invar"

lemma iam_empty_correct:
  "(iam_empty (), Map.empty)   iam_rel'" 
   by (simp add: iam_rel'_def br_def iam_α_def[abs_def] iam_empty_def)

lemma iam_update_correct:
  "(iam_update,op_map_update)  nat_rel  Id  iam_rel'   iam_rel'"
   by (auto simp: iam_rel'_def br_def Let_def array_get_array_set_other 
                  incr_correct iam_α_def[abs_def] iam_update_def)

lemma iam_lookup_correct:
  "(iam_lookup,op_map_lookup)  Id  iam_rel'  Idoption_rel"
   by (auto simp: iam_rel'_def br_def iam_lookup_def[abs_def])


lemma array_get_set_iff: "i<array_length a  
  array_get (array_set a i x) j = (if i=j then x else array_get a j)"
  by (auto simp: array_get_array_set_other)

lemma iam_delete_correct:
  "(iam_delete,op_map_delete)  Id  iam_rel'  iam_rel'"
  unfolding iam_α_def[abs_def] iam_delete_def[abs_def] iam_rel'_def br_def
  by (auto simp: Let_def array_get_set_iff)

definition iam_map_rel_def_internal: 
  "iam_map_rel Rk Rv  
    if Rk=nat_rel then Rviam_rel O iam_rel' else {}"
lemma iam_map_rel_def: 
  "nat_rel,Rviam_map_rel  Rviam_rel O iam_rel'" 
  unfolding iam_map_rel_def_internal relAPP_def by simp


lemmas [autoref_rel_intf] = REL_INTFI[of "iam_map_rel" i_map]

lemma iam_map_rel_sv[relator_props]:
  "single_valued Rv  single_valued (nat_rel,Rviam_map_rel)"
  unfolding iam_map_rel_def iam_rel'_def by tagged_solver

lemma iam_empty_impl: 
    "(iam_empty (), op_map_empty)  nat_rel,Riam_map_rel"
  unfolding iam_map_rel_def op_map_empty_def
  apply (intro relcompI)
  apply (rule param_iam_empty[THEN fun_relD], simp)
  apply (rule iam_empty_correct)
  done


lemma iam_lookup_impl: 
    "(iam_lookup, op_map_lookup) 
   nat_rel  nat_rel,Riam_map_rel  Roption_rel"
unfolding iam_map_rel_def
apply (intro fun_relI)
apply (elim relcompE)
apply (frule iam_lookup_correct[param_fo], assumption)
apply (frule param_iam_lookup[param_fo], assumption)
apply simp
done

lemma iam_update_impl:
   "(iam_update, op_map_update)  
     nat_rel  R  nat_rel,Riam_map_rel  nat_rel,Riam_map_rel"
  unfolding iam_map_rel_def
  apply (intro fun_relI, elim relcompEpair, intro relcompI)
  apply (erule (2) param_iam_update[param_fo])
  apply (rule iam_update_correct[param_fo])
  apply simp_all
  done

lemma iam_delete_impl: 
    "(iam_delete, op_map_delete) 
        nat_rel  nat_rel,Riam_map_rel  nat_rel,Riam_map_rel"
  unfolding iam_map_rel_def
  apply (intro fun_relI, elim relcompEpair, intro relcompI)
  apply (erule (1) param_iam_delete[param_fo])
  apply (rule iam_delete_correct[param_fo])
  by simp_all

lemmas iam_map_impl =
  iam_empty_impl
  iam_lookup_impl
  iam_update_impl
  iam_delete_impl

declare iam_map_impl[autoref_rules]



subsection ‹Iterator proofs›

abbreviation "iam_to_list a  it_to_list iam_iteratei a"

lemma distinct_iam_to_list_aux:
  shows "distinct xs; (i,_)set xs. i  n  
        distinct (iam_iteratei_aux n a 
            (λ_.True) (λx y. y @ [x]) xs)" 
   (is "_;_  distinct (?iam_to_list_aux n xs)")
proof (induction n arbitrary: xs)
  case (0 xs) thus ?case by simp
next
  case (Suc i xs)
    show ?case 
    proof (cases "array_get a i")
      case None
        with Suc.IH[OF Suc.prems(1)] Suc.prems(2)
            show ?thesis by force
    next
      case (Some x)
        let ?xs' = "xs @ [(i,x)]"
        from Suc.prems have "distinct ?xs'" and 
            "(i',x)set ?xs'. i'  i" by force+
        from Some and Suc.IH[OF this] show ?thesis by simp
  qed
qed

lemma distinct_iam_to_list:
  "distinct (iam_to_list a)"
unfolding it_to_list_def iam_iteratei_def
  by (force intro: distinct_iam_to_list_aux)

lemma iam_to_list_set_correct_aux:
  assumes "(a, m)  iam_rel'"
  shows "n  array_length a; map_to_set m - {(k,v). k < n} = set xs
          map_to_set m = 
             set (iam_iteratei_aux n a (λ_.True) (λx y. y @ [x]) xs)"
proof (induction n arbitrary: xs)
  case (0 xs)
    thus ?case by simp
next
  case (Suc n xs)
    with assms have [simp]: "array_get a n = m n" 
        unfolding iam_rel'_def br_def iam_α_def[abs_def] by simp
    show ?case 
    proof (cases "m n")
      case None
        with Suc.prems(2) have "map_to_set m - {(k,v). k < n} = set xs"
        unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
        from None and Suc.IH[OF _ this] and Suc.prems(1) 
            show ?thesis by simp
    next
      case (Some x)
        let ?xs' = "xs @ [(n,x)]"
        from Some and Suc.prems(2)
            have "map_to_set m - {(k,v). k < n} = set ?xs'"
            unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
        from Some and Suc.IH[OF _ this] and Suc.prems(1)
            show ?thesis by simp
    qed
qed

lemma iam_to_list_set_correct:
  assumes "(a, m)  iam_rel'"
  shows "map_to_set m = set (iam_to_list a)"
proof-
  from assms 
      have A: "map_to_set m - {(k, v). k < array_length a} = set []"
      unfolding map_to_set_def iam_rel'_def br_def iam_α_def[abs_def]
      by (force split: if_split_asm)
  with iam_to_list_set_correct_aux[OF assms _ A] show ?thesis
    unfolding it_to_list_def iam_iteratei_def by simp
qed

lemma iam_iteratei_aux_append:
  "n  length xs  iam_iteratei_aux n (Array (xs @ ys)) = 
             iam_iteratei_aux n (Array xs)"
apply (induction n)
apply force
apply (intro ext, auto split: option.split simp: nth_append)
done

lemma iam_iteratei_append: 
  "iam_iteratei (Array (xs @ [None])) c f σ =
       iam_iteratei (Array xs) c f σ"
  "iam_iteratei (Array (xs @ [Some x])) c f σ = 
       iam_iteratei (Array xs) c f 
       (if c σ then (f (length xs, x) σ) else σ)"
unfolding  iam_iteratei_def 
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force simp: nth_append iam_iteratei_aux_append) []
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force split: option.split 
             simp: nth_append iam_iteratei_aux_append) []
done


lemma iam_iteratei_aux_Cons:
  "n < array_length a 
      iam_iteratei_aux n a (λ_. True) (λx l. l @ [x]) (x#xs) =
      x # iam_iteratei_aux n a (λ_. True) (λx l. l @ [x]) xs"
    by (induction n arbitrary: xs, auto split: option.split)

lemma iam_to_list_append: 
  "iam_to_list (Array (xs @ [None])) = iam_to_list (Array xs)"
  "iam_to_list (Array (xs @ [Some x])) = 
       (length xs, x) # iam_to_list (Array xs)"
unfolding  it_to_list_def iam_iteratei_def
apply (simp add: iam_iteratei_aux_append)
apply (simp add: iam_iteratei_aux_Cons)
apply (simp add: iam_iteratei_aux_append)
done
    
lemma autoref_iam_is_iterator[autoref_ga_rules]: 
  shows "is_map_to_list nat_rel Rv iam_map_rel iam_to_list"
  unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
  fix a m'
  assume "(a,m')  nat_rel,Rviam_map_rel"
  then obtain a' where [param]: "(a,a')Rviam_rel" 
    and "(a',m')iam_rel'" unfolding iam_map_rel_def by blast
  
  have "(iam_to_list a, iam_to_list a') 
             nat_rel, Rvprod_rellist_rel" by parametricity

  moreover from distinct_iam_to_list and 
                iam_to_list_set_correct[OF (a',m')iam_rel'›]
      have "RETURN (iam_to_list a')  it_to_sorted_list
               (key_rel (λ_ _. True)) (map_to_set m')" 
      unfolding it_to_sorted_list_def key_rel_def[abs_def]
          by (force intro: refine_vcg)

  ultimately show "l'. (iam_to_list a, l')  
                            nat_rel, Rvprod_rellist_rel
                     RETURN l'  it_to_sorted_list (
                        key_rel (λ_ _. True)) (map_to_set m')" by blast
qed

(* We provide a ,,sorted'' iterator to simplify derivations of the
    generic algorithm library *)
lemmas [autoref_ga_rules] = 
  autoref_iam_is_iterator[unfolded is_map_to_list_def]

lemma iam_iteratei_altdef:
    "iam_iteratei a = foldli (iam_to_list a)" 
     (is "?f a = ?g (iam_to_list a)")
proof-
  obtain l where "a = Array l" by (cases a)
  have "?f (Array l) = ?g (iam_to_list (Array l))"
  proof (induction "length l" arbitrary: l)
    case (0 l)
      thus ?case by (intro ext, 
          simp add: iam_iteratei_def it_to_list_def)
  next
    case (Suc n l)
      hence "l  []" and [simp]: "length l = Suc n" by force+
      with append_butlast_last_id have [simp]: 
          "butlast l @ [last l] = l" by simp
      with Suc have [simp]: "length (butlast l) = n" by simp
      note IH = Suc(1)[OF this[symmetric]]
      let ?l' = "iam_to_list (Array l)"

      show ?case
      proof (cases "last l")
        case None
          have "?f (Array l) = 
              ?f (Array (butlast l @ [last l]))" by simp
          also have "... = ?g (iam_to_list (Array (butlast l)))"
              by (force simp: None iam_iteratei_append IH)
          also have "iam_to_list (Array (butlast l)) = 
              iam_to_list (Array (butlast l @ [last l]))"
              using None by (simp add: iam_to_list_append)
          finally show "?f (Array l) = ?g ?l'" by simp
      next
        case (Some x)
          have "?f (Array l) = 
              ?f (Array (butlast l @ [last l]))" by simp
          also have "... = ?g (iam_to_list 
              (Array (butlast l @ [last l])))" 
              by (force simp: IH iam_iteratei_append 
                      iam_to_list_append Some)
          finally show ?thesis by simp
      qed
  qed
  thus ?thesis by (simp add: a = Array l)
qed


lemma pi_iam[icf_proper_iteratorI]: 
  "proper_it (iam_iteratei a) (iam_iteratei a)"
unfolding proper_it_def by (force simp: iam_iteratei_altdef)

lemma pi'_iam[icf_proper_iteratorI]: 
  "proper_it' iam_iteratei iam_iteratei"
  by (rule proper_it'I, rule pi_iam)

end

Theory Impl_Bit_Set

section "Bitvector based Sets of Naturals"
theory Impl_Bit_Set
imports 
  "../../Iterator/Iterator" 
  "../Intf/Intf_Set" 
  Native_Word.Bits_Integer
begin
  text ‹
    Based on the Native-Word library, using bit-operations on arbitrary
    precision integers. Fast for sets of small numbers, 
    direct and fast implementations of equal, union, inter, diff.

    Note: On Poly/ML 5.5.1, bit-operations on arbitrary precision integers are 
      rather inefficient. Use MLton instead, here they are efficiently implemented.
›

  type_synonym bitset = integer

  definition bs_α :: "bitset  nat set" where "bs_α s  { n . bit s n}"


context includes integer.lifting begin

  definition bs_empty :: "unit  bitset" where "bs_empty  λ_. 0"


  lemma bs_empty_correct: "bs_α (bs_empty ()) = {}"
    unfolding bs_α_def bs_empty_def 
    apply transfer
    by auto

  definition bs_isEmpty :: "bitset  bool" where "bs_isEmpty s  s=0"

  lemma bs_isEmpty_correct: "bs_isEmpty s  bs_α s = {}"
    unfolding bs_isEmpty_def bs_α_def 
    by transfer (auto simp: bin_eq_iff) 
    
  term set_bit
  definition bs_insert :: "nat  bitset  bitset" where
    "bs_insert i s  set_bit s i True"

  lemma bs_insert_correct: "bs_α (bs_insert i s) = insert i (bs_α s)"
    unfolding bs_α_def bs_insert_def
    apply transfer
    apply auto
    apply (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)
    apply (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)
    by (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)

  definition bs_delete :: "nat  bitset  bitset" where
    "bs_delete i s  set_bit s i False"

  lemma bs_delete_correct: "bs_α (bs_delete i s) = (bs_α s) - {i}"
    unfolding bs_α_def bs_delete_def
    apply transfer
    apply auto
    apply (metis bin_nth_ops(1) int_set_bit_False_conv_NAND)
    apply (metis (full_types) bin_nth_sc set_bit_int_def)
    by (metis (full_types) bin_nth_sc_gen set_bit_int_def)
  
  definition bs_mem :: "nat  bitset  bool" where
    "bs_mem i s  bit s i"

  lemma bs_mem_correct: "bs_mem i s  ibs_α s"
    unfolding bs_mem_def bs_α_def by transfer auto


  definition bs_eq :: "bitset  bitset  bool" where 
    "bs_eq s1 s2  (s1=s2)"

  lemma bs_eq_correct: "bs_eq s1 s2  bs_α s1 = bs_α s2"
    unfolding bs_eq_def bs_α_def
    including integer.lifting
    apply transfer
    apply auto
    by (metis bin_eqI mem_Collect_eq)

  definition bs_subset_eq :: "bitset  bitset  bool" where
    "bs_subset_eq s1 s2  s1 AND NOT s2 = 0"
  
  lemma bs_subset_eq_correct: "bs_subset_eq s1 s2  bs_α s1  bs_α s2"
    unfolding bs_α_def bs_subset_eq_def
    by transfer (auto simp add: bit_eq_iff bin_nth_ops)

  definition bs_disjoint :: "bitset  bitset  bool" where
    "bs_disjoint s1 s2  s1 AND s2 = 0"
  
  lemma bs_disjoint_correct: "bs_disjoint s1 s2  bs_α s1  bs_α s2 = {}"
    unfolding bs_α_def bs_disjoint_def
    by transfer (auto simp add: bit_eq_iff bin_nth_ops)

  definition bs_union :: "bitset  bitset  bitset" where
    "bs_union s1 s2 = s1 OR s2"

  lemma bs_union_correct: "bs_α (bs_union s1 s2) = bs_α s1  bs_α s2"
    unfolding bs_α_def bs_union_def
    by transfer (auto simp: bin_nth_ops)

  definition bs_inter :: "bitset  bitset  bitset" where
    "bs_inter s1 s2 = s1 AND s2"

  lemma bs_inter_correct: "bs_α (bs_inter s1 s2) = bs_α s1  bs_α s2"
    unfolding bs_α_def bs_inter_def
    by transfer (auto simp: bin_nth_ops)

  definition bs_diff :: "bitset  bitset  bitset" where
    "bs_diff s1 s2 = s1 AND NOT s2"

  lemma bs_diff_correct: "bs_α (bs_diff s1 s2) = bs_α s1 - bs_α s2"
    unfolding bs_α_def bs_diff_def
    by transfer (auto simp: bin_nth_ops)

  definition bs_UNIV :: "unit  bitset" where "bs_UNIV  λ_. -1"

  lemma bs_UNIV_correct: "bs_α (bs_UNIV ()) = UNIV"
    unfolding bs_α_def bs_UNIV_def
    by transfer (auto)

  definition bs_complement :: "bitset  bitset" where
    "bs_complement s = NOT s"

  lemma bs_complement_correct: "bs_α (bs_complement s) = - bs_α s"
    unfolding bs_α_def bs_complement_def
    by transfer (auto simp: bin_nth_ops)

end

  lemmas bs_correct[simp] = 
    bs_empty_correct
    bs_isEmpty_correct
    bs_insert_correct
    bs_delete_correct
    bs_mem_correct
    bs_eq_correct
    bs_subset_eq_correct
    bs_disjoint_correct
    bs_union_correct
    bs_inter_correct
    bs_diff_correct
    bs_UNIV_correct
    bs_complement_correct


subsection ‹Autoref Setup›

definition bs_set_rel_def_internal: 
  "bs_set_rel Rk  
    if Rk=nat_rel then br bs_α (λ_. True) else {}"
lemma bs_set_rel_def: 
  "nat_relbs_set_rel  br bs_α (λ_. True)" 
  unfolding bs_set_rel_def_internal relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of "bs_set_rel" i_set]

lemma bs_set_rel_sv[relator_props]: "single_valued (nat_relbs_set_rel)"
  unfolding bs_set_rel_def by auto


term bs_empty

lemma [autoref_rules]: "(bs_empty (),{})nat_relbs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_UNIV (),UNIV)nat_relbs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_isEmpty,op_set_isEmpty)nat_relbs_set_rel  bool_rel"
  by (auto simp: bs_set_rel_def br_def)

term insert
lemma [autoref_rules]: "(bs_insert,insert)nat_rel  nat_relbs_set_rel  nat_relbs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

term op_set_delete
lemma [autoref_rules]: "(bs_delete,op_set_delete)nat_rel  nat_relbs_set_rel  nat_relbs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_mem,(∈))nat_rel  nat_relbs_set_rel  bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_eq,(=))nat_relbs_set_rel  nat_relbs_set_rel  bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_subset_eq,(⊆))nat_relbs_set_rel  nat_relbs_set_rel  bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_union,(∪))nat_relbs_set_rel  nat_relbs_set_rel  nat_relbs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_inter,(∩))nat_relbs_set_rel  nat_relbs_set_rel  nat_relbs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_diff,(-))nat_relbs_set_rel  nat_relbs_set_rel  nat_relbs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_complement,uminus)nat_relbs_set_rel  nat_relbs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_disjoint,op_set_disjoint)nat_relbs_set_rel  nat_relbs_set_rel  bool_rel"
  by (auto simp: bs_set_rel_def br_def)


export_code
    bs_empty
    bs_isEmpty
    bs_insert
    bs_delete
    bs_mem
    bs_eq
    bs_subset_eq
    bs_disjoint
    bs_union
    bs_inter
    bs_diff
    bs_UNIV
    bs_complement
 in SML

(*

    TODO: Iterator

  definition "maxbi s ≡ GREATEST i. s!!i"

  lemma cmp_BIT_append_conv[simp]: "i < i BIT b ⟷ ((i≥0 ∧ b=1) ∨ i>0)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_cmp_conv[simp]: "i BIT b < i ⟷ ((i<0 ∧ (i=-1 ⟶ b=0)))"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_eq[simp]: fixes i :: int shows "i BIT b = i ⟷ (i=0 ∧ b=0) ∨ (i=-1 ∧ b=1)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma int_no_bits_eq_zero[simp]:
    fixes s::int shows "(∀i. ¬s!!i) ⟷ s=0"
    apply clarsimp
    by (metis bin_eqI bin_nth_code(1))

  lemma int_obtain_bit:
    fixes s::int
    assumes "s≠0"
    obtains i where "s!!i"
    by (metis assms int_no_bits_eq_zero)
    
  lemma int_bit_bound:
    fixes s::int
    assumes "s≥0" and "s!!i"
    shows "i ≤ Bits_Integer.log2 s"
  proof (rule ccontr)
    assume "¬i≤Bits_Integer.log2 s"
    hence "i>Bits_Integer.log2 s" by simp
    hence "i - 1 ≥ Bits_Integer.log2 s" by simp
    hence "s AND bin_mask (i - 1) = s" by (simp add: int_and_mask `s≥0`)
    hence "¬ (s!!i)"  
      by clarsimp (metis Nat.diff_le_self bin_nth_mask bin_nth_ops(1) leD)
    thus False using `s!!i` ..
  qed

  lemma int_bit_bound':
    fixes s::int
    assumes "s≥0" and "s!!i"
    shows "i < Bits_Integer.log2 s + 1"
    using assms int_bit_bound by smt

  lemma int_obtain_bit_pos:
    fixes s::int
    assumes "s>0"
    obtains i where "s!!i" "i < Bits_Integer.log2 s + 1"
    by (metis assms int_bit_bound' int_no_bits_eq_zero less_imp_le less_irrefl)

  lemma maxbi_set: fixes s::int shows "s>0 ⟹ s!!maxbi s"
    unfolding maxbi_def
    apply (rule int_obtain_bit_pos, assumption)
    apply (rule GreatestI_nat, assumption)
    apply (intro allI impI)
    apply (rule int_bit_bound'[rotated], assumption)
    by auto

  lemma maxbi_max: fixes s::int shows "i>maxbi s ⟹ ¬ s!!i"
    oops

  function get_maxbi :: "nat ⇒ int ⇒ nat" where
    "get_maxbi n s = (let
        b = 1<<n
      in
        if b≤s then get_maxbi (n+1) s
        else n
    )"
    by pat_completeness auto

  termination
    apply (rule "termination"[of "measure (λ(n,s). nat (s + 1 - (1<<n)))"])
    apply simp
    apply auto
    by (smt bin_mask_ge0 bin_mask_p1_conv_shift)


  partial_function (tailrec) 
    bs_iterate_aux :: "nat ⇒ bitset ⇒ ('σ ⇒ bool) ⇒ (nat ⇒ 'σ ⇒ 'σ) ⇒ 'σ ⇒ 'σ"
    where "bs_iterate_aux i s c f σ = (
    if s < 1 << i then σ
    else if ¬c σ then σ
    else if test_bit s i then bs_iterate_aux (i+1) s c f (f i σ)
    else bs_iterate_aux (i+1) s c f σ
  )"

  definition bs_iteratei :: "bitset ⇒ (nat,'σ) set_iterator" where 
    "bs_iteratei s = bs_iterate_aux 0 s"


  definition bs_set_rel_def_internal: 
    "bs_set_rel Rk ≡ 
      if Rk=nat_rel then br bs_α (λ_. True) else {}"
  lemma bs_set_rel_def: 
    "⟨nat_rel⟩bs_set_rel ≡ br bs_α (λ_. True)" 
    unfolding bs_set_rel_def_internal relAPP_def by simp


  definition "bs_to_list ≡ it_to_list bs_iteratei"

  lemma "(1::int)<<i = 2^i"
    by (simp add: shiftl_int_def)

  lemma 
    fixes s :: int
    assumes "s≥0"  
    shows "s < 1<<i ⟷ Bits_Integer.log2 s ≤ i"
    using assms
  proof (induct i arbitrary: s)
    case 0 thus ?case by auto
  next
    case (Suc i)
    note GE=`0≤s`
    show ?case proof
      assume "s < 1 << Suc i"

      have "s ≤ (s >> 1) BIT 1"

      hence "(s >> 1) < (1<<i)" using GE apply auto
      with Suc.hyps[of "s div 2"]


    apply auto
    


  lemma "distinct (bs_to_list s)"
    unfolding bs_to_list_def it_to_list_def bs_iteratei_def[abs_def]
  proof -
    {
      fix l i
      assume "distinct l"
      show "distinct (bs_iterate_aux 0 s (λ_. True) (λx l. l @ [x]) [])"

    }


    apply auto
    



    lemma "set (bs_to_list s) = bs_α s"


  lemma autoref_iam_is_iterator[autoref_ga_rules]: 
    shows "is_set_to_list nat_rel bs_set_rel bs_to_list"
    unfolding is_set_to_list_def is_set_to_sorted_list_def
    apply clarsimp
    unfolding it_to_sorted_list_def
    apply (refine_rcg refine_vcg)
    apply (simp_all add: bs_set_rel_def br_def)

  proof (clarsimp)



  definition 

"iterate s c f σ ≡ let
    i=0;
    b=0;
    (_,_,s) = while 
  in

  end"


*)


end

Theory Impl_Uv_Set

theory Impl_Uv_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
  Native_Word.Uint
begin

  subsection ‹Bit-Vectors as Lists of Words›

  subsubsection ‹Lookup›

  primrec lookup :: "nat  ('a::len) word list  bool" where
    "lookup _ []  False"
  | "lookup n (w#ws)
       (if n<LENGTH('a) then test_bit w n else lookup (n-LENGTH('a)) ws)"

  lemma lookup_append[simp]: "lookup n (w1@w2 :: 'a::len word list)
     (
      if n < LENGTH('a) * length w1 then
        lookup n w1
      else lookup (n - LENGTH('a) * length w1) w2)"
    by (induction w1 arbitrary: n) auto

  lemma lookup_zeroes[simp]: "lookup i (replicate n (0::'a::len word)) = False"
    by (induction n arbitrary: i) auto

  lemma lookup_out_of_bound:
    fixes uv :: "'a::len word list"
    assumes "¬ i < LENGTH('a::len) * length uv"
    shows "¬ lookup i uv"
    using assms
    by (induction uv arbitrary: i) auto


  subsubsection ‹Empty›

  definition empty :: "'a::len word list" where "empty = []"

  subsubsection ‹Set and Reset Bit›

  function single_bit :: "nat  ('a::len) word list"
    where "single_bit n = (
      if (n<LENGTH('a)) then
        [set_bit 0 n True]
      else 0#single_bit (n-LENGTH('a)))"
    by pat_completeness auto
  termination
    apply (relation "measure id")
    apply simp
    apply (simp add: not_less less_diff_conv2)
    done

  declare single_bit.simps[simp del]

  lemma lookup_single_bit[simp]: "lookup i ((single_bit n)::'a::len word list)  i = n"
    apply (induction n arbitrary: i rule: single_bit.induct)
    apply (subst single_bit.simps)
    apply (auto simp: bin_nth_sc_gen)
    done

  primrec set_bit :: "nat  'a::len word list  'a::len word list" where
    "set_bit i [] = single_bit i"
  | "set_bit i (w#ws) = (
      if i<LENGTH('a) then
        Bit_Operations.set_bit i w # ws
      else
        w # set_bit (i - LENGTH('a)) ws)"

  lemma set_bit_lookup[simp]: "lookup i (set_bit j ws)  (lookup i ws  i=j)"
    apply (induction ws arbitrary: i j)
     apply (auto simp add: test_bit_eq_bit word_size ring_bit_operations_class.bit_set_bit_iff)
    done

  primrec reset_bit :: "nat  'a::len word list  'a::len word list" where
    "reset_bit i [] = []"
  | "reset_bit i (w#ws) = (
      if i<LENGTH('a) then
        unset_bit i w # ws
      else
        w # reset_bit (i - LENGTH('a)) ws)"

  lemma reset_bit_lookup[simp]: "lookup i (reset_bit j ws)  (lookup i ws  ij)"
    apply (induction ws arbitrary: i j)
    apply (auto simp: test_bit_eq_bit word_size bit_unset_bit_iff)
    done

  subsubsection ‹Binary Operations›

  definition
    is_bin_op_impl
    :: "(boolboolbool)  ('a::len word  'a::len word  'a::len word)  bool"
    where "is_bin_op_impl f g 
    (w v.  i<LENGTH('a). test_bit (g w v) i  f (test_bit w i) (test_bit v i))"

  definition "is_strict_bin_op_impl f g  is_bin_op_impl f g  f False False = False"

  fun binary :: "('a::len word  'a::len word  'a::len word)
     'a::len word list  'a::len word list  'a::len word list"
    where
    "binary f [] [] = []"
  | "binary f [] (w#ws) = f 0 w # binary f [] ws"
  | "binary f (v#vs) [] = f v 0 # binary f vs []"
  | "binary f (v#vs) (w#ws) = f v w # binary f vs ws"

  lemma binary_lookup:
    assumes "is_strict_bin_op_impl f g"
    shows "lookup i (binary g ws vs)  f (lookup i ws) (lookup i vs)"
    using assms
    apply (induction g ws vs arbitrary: i rule: binary.induct)
    apply (auto simp: is_strict_bin_op_impl_def is_bin_op_impl_def)
    done

  subsection ‹Abstraction to Sets of Naturals›

  definition "α uv  {n. lookup n uv}"

  lemma memb_correct: "lookup i ws  iα ws"
    by (auto simp: α_def)

  lemma empty_correct: "α empty = {}"
    by (simp add: α_def empty_def)

  lemma single_bit_correct: (single_bit n) = {n}"
    by (simp add: α_def)

  lemma insert_correct: (set_bit i ws) = Set.insert i (α ws)"
    by (auto simp add: α_def)

  lemma delete_correct: (reset_bit i ws) = (α ws) - {i}"
    by (auto simp add: α_def)

  lemma binary_correct:
    assumes "is_strict_bin_op_impl f g"
    shows (binary g ws vs) = { i . f (iα ws) (iα vs) }"
    unfolding α_def
    by (auto simp add: binary_lookup[OF assms])

  fun union :: "'a::len word list  'a::len word list  'a::len word list"
    where
    "union [] ws = ws"
  | "union vs [] = vs"
  | "union (v#vs) (w#ws) = (v OR w) # union vs ws"

  lemma union_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (union vs ws)  lookup i vs  lookup i ws"
    apply (induction vs ws arbitrary: i rule: union.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma union_correct: (union ws vs) = α ws  α vs"
    by (auto simp add: α_def)

  fun inter :: "'a::len word list  'a::len word list  'a::len word list"
    where
    "inter [] ws = []"
  | "inter vs [] = []"
  | "inter (v#vs) (w#ws) = (v AND w) # inter vs ws"

  lemma inter_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (inter vs ws)  lookup i vs  lookup i ws"
    apply (induction vs ws arbitrary: i rule: inter.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma inter_correct: (inter ws vs) = α ws  α vs"
    by (auto simp add: α_def)


  fun diff :: "'a::len word list  'a::len word list  'a::len word list"
    where
    "diff [] ws = []"
  | "diff vs [] = vs"
  | "diff (v#vs) (w#ws) = (v AND NOT w) # diff vs ws"

  lemma diff_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (diff vs ws)  lookup i vs - lookup i ws"
    apply (induction vs ws arbitrary: i rule: diff.induct)
    apply (auto simp: word_ops_nth_size word_size)
    done

  lemma diff_correct: (diff ws vs) = α ws - α vs"
    by (auto simp add: α_def)

  fun zeroes :: "'a::len word list  bool" where
    "zeroes []  True"
  | "zeroes (w#ws)  w=0  zeroes ws"

  lemma zeroes_lookup: "zeroes ws  (i. ¬lookup i ws)"
    apply (induction ws)
    apply (auto simp: word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma isEmpty_correct: "zeroes ws  α ws = {}"
    by (auto simp: zeroes_lookup α_def)

  fun equal :: "'a::len word list  'a::len word list  bool" where
    "equal [] []  True"
  | "equal [] ws  zeroes ws"
  | "equal vs []  zeroes vs"
  | "equal (v#vs) (w#ws)  v=w  equal vs ws"

  lemma equal_lookup:
    fixes vs ws :: "'a::len word list"
    shows "equal vs ws  (i. lookup i vs = lookup i ws)"
  proof (induction vs ws rule: equal.induct)
    fix v w and vs ws :: "'a::len word list"
    assume IH: "equal vs ws = (i. lookup i vs = lookup i ws)"
    show "equal (v # vs) (w # ws) = (i. lookup i (v # vs) = lookup i (w # ws))"
    proof (rule iffI, rule allI)
      fix i
      assume "equal (v#vs) (w#ws)"
      thus "lookup i (v # vs) = lookup i (w # ws)"
        by (auto simp: IH)
    next
      assume "i. lookup i (v # vs) = lookup i (w # ws)"
      thus "equal (v # vs) (w # ws)"
        apply (auto simp: word_eq_iff IH)
        apply metis
        apply metis
        apply (drule_tac x="i + LENGTH('a)" in spec)
        apply auto []
        apply (drule_tac x="i + LENGTH('a)" in spec)
        apply auto []
        done
    qed
  qed (auto simp: zeroes_lookup)

  lemma equal_correct: "equal vs ws  α vs = α ws"
    by (auto simp: α_def equal_lookup)

  fun subseteq :: "'a::len word list  'a::len word list  bool" where
    "subseteq [] ws  True"
  | "subseteq vs []  zeroes vs"
  | "subseteq (v#vs) (w#ws)  (v AND NOT w = 0)  subseteq vs ws"


  lemma subseteq_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subseteq vs ws  (i. lookup i vs  lookup i ws)"
    apply (induction vs ws rule: subseteq.induct)
    apply simp
    apply (auto simp: zeroes_lookup) []
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma subseteq_correct: "subseteq vs ws  α vs  α ws"
    by (auto simp: α_def subseteq_lookup)


  fun subset :: "'a::len word list  'a::len word list  bool" where
    "subset [] ws  ¬zeroes ws"
  | "subset vs []  False"
  | "subset (v#vs) (w#ws)  (if v=w then subset vs ws else subseteq (v#vs) (w#ws))"

  lemma subset_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subset vs ws  ((i. lookup i vs  lookup i ws)
       (i. ¬lookup i vs  lookup i ws))"
    apply (induction vs ws rule: subset.induct)
    apply (simp add: zeroes_lookup)
    apply (simp add: zeroes_lookup) []
    apply (simp del: subseteq_correct add: subseteq_lookup)
    apply safe
    apply simp_all
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    done

  lemma subset_correct: "subset vs ws  α vs  α ws"
    by (auto simp: α_def subset_lookup)


  fun disjoint :: "'a::len word list  'a::len word list  bool" where
    "disjoint [] ws  True"
  | "disjoint vs []  True"
  | "disjoint (v#vs) (w#ws)  (v AND w = 0)  disjoint vs ws"

  lemma disjoint_lookup:
    fixes vs ws :: "'a::len word list"
    shows "disjoint vs ws  (i. ¬(lookup i vs  lookup i ws))"
    apply (induction vs ws rule: disjoint.induct)
    apply simp
    apply simp
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma disjoint_correct: "disjoint vs ws  α vs  α ws = {}"
    by (auto simp: α_def disjoint_lookup)


subsection ‹Lifting to Uint›
  type_synonym uint_vector = "uint list"

  lift_definition uv_α :: "uint_vector  nat set" is α .
  lift_definition uv_lookup :: "nat  uint_vector  bool" is lookup .
  lift_definition uv_empty :: "uint_vector" is empty .
  lift_definition uv_single_bit :: "nat  uint_vector" is single_bit .
  lift_definition uv_set_bit :: "nat  uint_vector  uint_vector" is set_bit .
  lift_definition uv_reset_bit :: "nat  uint_vector  uint_vector" is reset_bit .
  lift_definition uv_union :: "uint_vector  uint_vector  uint_vector" is union .
  lift_definition uv_inter :: "uint_vector  uint_vector  uint_vector" is inter .
  lift_definition uv_diff :: "uint_vector  uint_vector  uint_vector" is diff .
  lift_definition uv_zeroes :: "uint_vector  bool" is zeroes .
  lift_definition uv_equal :: "uint_vector  uint_vector  bool" is equal .
  lift_definition uv_subseteq :: "uint_vector  uint_vector  bool" is subseteq .
  lift_definition uv_subset :: "uint_vector  uint_vector  bool" is subset .
  lift_definition uv_disjoint :: "uint_vector  uint_vector  bool" is disjoint .

  lemmas uv_memb_correct = memb_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_empty_correct = empty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_single_bit_correct = single_bit_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_insert_correct = insert_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_delete_correct = delete_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_union_correct = union_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_inter_correct = inter_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_diff_correct = diff_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_isEmpty_correct = isEmpty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_equal_correct = equal_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subseteq_correct = subseteq_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subset_correct = subset_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_disjoint_correct = disjoint_correct[where 'a=dflt_size, Transfer.transferred]



  lemmas [where 'a=dflt_size, Transfer.transferred, code] =
    lookup.simps
    empty_def
    single_bit.simps
    set_bit.simps
    reset_bit.simps
    union.simps
    inter.simps
    diff.simps
    zeroes.simps
    equal.simps
    subseteq.simps
    subset.simps
    disjoint.simps


  hide_const (open) α lookup empty single_bit set_bit reset_bit union inter diff zeroes
    equal subseteq subset disjoint


subsection ‹Autoref Setup›

  definition uv_set_rel_def_internal:
    "uv_set_rel Rk 
      if Rk=nat_rel then br uv_α (λ_. True) else {}"
  lemma uv_set_rel_def:
    "nat_reluv_set_rel  br uv_α (λ_. True)"
    unfolding uv_set_rel_def_internal relAPP_def by simp

  lemmas [autoref_rel_intf] = REL_INTFI[of "uv_set_rel" i_set]

  lemma uv_set_rel_sv[relator_props]: "single_valued (nat_reluv_set_rel)"
    unfolding uv_set_rel_def by auto

  lemma uv_autoref[autoref_rules,param]:
    "(uv_lookup,(∈))  nat_rel  nat_reluv_set_rel  bool_rel"
    "(uv_empty,{})  nat_reluv_set_rel"
    "(uv_set_bit,insert)  nat_rel  nat_reluv_set_rel  nat_reluv_set_rel"
    "(uv_reset_bit,op_set_delete)  nat_rel  nat_reluv_set_rel  nat_reluv_set_rel"
    "(uv_union,(∪))  nat_reluv_set_rel  nat_reluv_set_rel  nat_reluv_set_rel"
    "(uv_inter,(∩))  nat_reluv_set_rel  nat_reluv_set_rel  nat_reluv_set_rel"
    "(uv_diff,(-))  nat_reluv_set_rel  nat_reluv_set_rel  nat_reluv_set_rel"
    "(uv_zeroes,op_set_isEmpty)  nat_reluv_set_rel  bool_rel"
    "(uv_equal,(=))  nat_reluv_set_rel  nat_reluv_set_rel  bool_rel"
    "(uv_subseteq,(⊆))  nat_reluv_set_rel  nat_reluv_set_rel  bool_rel"
    "(uv_subset,(⊂))  nat_reluv_set_rel  nat_reluv_set_rel  bool_rel"
    "(uv_disjoint,op_set_disjoint)  nat_reluv_set_rel  nat_reluv_set_rel  bool_rel"
    by (auto
      simp: uv_set_rel_def br_def
      simp: uv_memb_correct uv_empty_correct uv_insert_correct uv_delete_correct
      simp: uv_union_correct uv_inter_correct uv_diff_correct uv_isEmpty_correct
      simp: uv_equal_correct uv_subseteq_correct uv_subset_correct uv_disjoint_correct)


  export_code
    uv_lookup
    uv_empty
    uv_single_bit
    uv_set_bit
    uv_reset_bit
    uv_union
    uv_inter
    uv_diff
    uv_zeroes
    uv_equal
    uv_subseteq
    uv_subset
    uv_disjoint
  checking SML Scala Haskell? OCaml?

end

Theory Gen_Hash

theory Gen_Hash
imports "../Intf/Intf_Hash"
begin

definition "prod_bhc bhc1 bhc2  λn (a,b). (bhc1 n a * 33 + bhc2 n b) mod n"

lemma prod_bhc_ga[autoref_ga_rules]:
  " GEN_ALGO_tag (is_bounded_hashcode R eq1 bhc1); 
     GEN_ALGO_tag (is_bounded_hashcode S eq2 bhc2) 
   is_bounded_hashcode (R×rS) (prod_eq eq1 eq2) (prod_bhc bhc1 bhc2)"
  unfolding is_bounded_hashcode_def prod_bhc_def prod_eq_def[abs_def]
  apply safe
  apply (auto dest: fun_relD simp: Domain_unfold; metis)+
  done

lemma prod_dhs_ga[autoref_ga_rules]:
  " GEN_ALGO_tag (is_valid_def_hm_size TYPE('a) n1);
     GEN_ALGO_tag (is_valid_def_hm_size TYPE('b) n2) 
    is_valid_def_hm_size TYPE('a*'b) (n1+n2)"
   unfolding is_valid_def_hm_size_def by auto

end

Theory GenCF

section ‹\isaheader{Generic Collection Framework (Internal)}›
theory GenCF
imports 
  "Impl/Impl_List_Set" 
  "Impl/Impl_List_Map" 
  "Impl/Impl_RBT_Map" 
  "Impl/Impl_Array_Map"
  "Impl/Impl_Array_Hash_Map"
  "Impl/Impl_Array_Stack"
  "Impl/Impl_Cfun_Set"
  "Impl/Impl_Bit_Set"
  "Impl/Impl_Uv_Set"
  "Gen/Gen_Set"
  "Gen/Gen_Map"
  "Gen/Gen_Map2Set"
  "Gen/Gen_Comp"
  "Gen/Gen_Hash"
  "../Lib/Code_Target_ICF"
begin

  text ‹Use one of the Refine_Dflt›-theories as entry-point!›

  text ‹Useful Abbreviations›
  abbreviation "dflt_rs_rel  map2set_rel dflt_rm_rel"
  abbreviation "iam_set_rel  map2set_rel iam_map_rel"
  abbreviation "dflt_ahs_rel  map2set_rel dflt_ahm_rel"

  abbreviation ahs_rel where "ahs_rel bhc  (map2set_rel (ahm_rel bhc))"

end

Theory ICF_Chapter

(*<*)
theory ICF_Chapter
imports Main 
begin
(*>*)
text_raw‹\isachapter{The Original Isabelle Collection Framework}›

text ‹
  This chapter contains the original Isabelle Collection Framework. 
  It contains a vast amount of verified collection data structures, that are
  included either directly or by parameterization via locales.

  Generic algorithms need to be instantiated manually, and nesting of 
  collections (e.g.\ sets of sets) is not supported.
›

(*<*)
end
(*>*)

Theory ICF_Spec_Chapter

(*<*)
theory ICF_Spec_Chapter imports Main begin 
(*>*)
text_raw ‹\isasection{Specifications} \label{ch:specs}›
(*<*)
end
(*>*)

Theory SetSpec

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Specification of Sets}›
theory SetSpec
imports ICF_Spec_Base
begin
text_raw‹\label{thy:SetSpec}›

(*@intf Set
  @abstype 'a set
  Sets
*)

text ‹
  This theory specifies set operations by means of a mapping to
  HOL's standard sets.
›

(* Drop some notation that gets in the way here*)
(*no_notation member (infixl "mem" 55)*)
notation insert ("set'_ins")

type_synonym ('x,'s) set_α = "'s  'x set"
type_synonym ('x,'s) set_invar = "'s  bool"
locale set =
  ― ‹Abstraction to set›
  fixes α :: "'s  'x set"
  ― ‹Invariant›
  fixes invar :: "'s  bool"

locale set_no_invar = set +
  assumes invar[simp, intro!]: "s. invar s"

subsection "Basic Set Functions"

subsubsection "Empty set"

locale set_empty = set +
  constrains α :: "'s  'x set"
  fixes empty :: "unit  's"
  assumes empty_correct:
    "α (empty ()) = {}"
    "invar (empty ())"

subsubsection "Membership Query"

locale set_memb = set +
  constrains α :: "'s  'x set"
  fixes memb :: "'x  's  bool"
  assumes memb_correct:
    "invar s  memb x s  x  α s"

subsubsection "Insertion of Element"

locale set_ins = set +
  constrains α :: "'s  'x set"
  fixes ins :: "'x  's  's"
  assumes ins_correct:
    "invar s  α (ins x s) = set_ins x (α s)"
    "invar s  invar (ins x s)"

subsubsection "Disjoint Insert"

locale set_ins_dj = set +
  constrains α :: "'s  'x set"
  fixes ins_dj :: "'x  's  's"
  assumes ins_dj_correct:
    "invar s; xα s  α (ins_dj x s) = set_ins x (α s)"
    "invar s; xα s  invar (ins_dj x s)"

subsubsection "Deletion of Single Element"

locale set_delete = set +
  constrains α :: "'s  'x set"
  fixes delete :: "'x  's  's"
  assumes delete_correct:
    "invar s  α (delete x s) = α s - {x}"
    "invar s  invar (delete x s)"

subsubsection "Emptiness Check"

locale set_isEmpty = set +
  constrains α :: "'s  'x set"
  fixes isEmpty :: "'s  bool"
  assumes isEmpty_correct:
    "invar s  isEmpty s  α s = {}"

subsubsection "Bounded Quantifiers"

locale set_ball = set +
  constrains α :: "'s  'x set"
  fixes ball :: "'s  ('x  bool)  bool"
  assumes ball_correct: "invar S  ball S P  (xα S. P x)"

locale set_bex = set +
  constrains α :: "'s  'x set"
  fixes bex :: "'s  ('x  bool)  bool"
  assumes bex_correct: "invar S  bex S P  (xα S. P x)"

subsubsection "Finite Set"
locale finite_set = set +
  assumes finite[simp, intro!]: "invar s  finite (α s)"

subsubsection "Size"

locale set_size = finite_set +
  constrains α :: "'s  'x set"
  fixes size :: "'s  nat"
  assumes size_correct: 
    "invar s  size s = card (α s)"
  
locale set_size_abort = finite_set +
  constrains α :: "'s  'x set"
  fixes size_abort :: "nat  's  nat"
  assumes size_abort_correct: 
    "invar s  size_abort m s = min m (card (α s))"

subsubsection "Singleton sets"

locale set_sng = set +
  constrains α :: "'s  'x set"
  fixes sng :: "'x  's"
  assumes sng_correct:
    "α (sng x) = {x}"
    "invar (sng x)"

locale set_isSng = set +
  constrains α :: "'s  'x set"
  fixes isSng :: "'s  bool"
  assumes isSng_correct:
    "invar s  isSng s  (e. α s = {e})"
begin
  lemma isSng_correct_exists1 :
    "invar s  (isSng s  (∃!e. (e  α s)))"
  by (auto simp add: isSng_correct)

  lemma isSng_correct_card :
    "invar s  (isSng s  (card (α s) = 1))"
  by (auto simp add: isSng_correct card_Suc_eq)
end

subsection "Iterators"
text ‹
  An iterator applies a
  function to a state and all the elements of the set.
  The function is applied in any order. Proofs over the iteration are
  done by establishing invariants over the iteration.
  Iterators may have a break-condition, that interrupts the iteration before
  the last element has been visited.
›

(* Deprecated *)
(*
locale set_iteratei = finite_set +
  constrains α :: "'s ⇒ 'x set"
  fixes iteratei :: "'s ⇒ ('x, 'σ) set_iterator"

  assumes iteratei_rule: "invar S ⟹ set_iterator (iteratei S) (α S)"
begin
  lemma iteratei_rule_P:
    "⟦
      invar S;
      I (α S) σ0;
      !!x it σ. ⟦ c σ; x ∈ it; it ⊆ α S; I it σ ⟧ ⟹ I (it - {x}) (f x σ);
      !!σ. I {} σ ⟹ P σ;
      !!σ it. ⟦ it ⊆ α S; it ≠ {}; ¬ c σ; I it σ ⟧ ⟹ P σ
    ⟧ ⟹ P (iteratei S c f σ0)"
   apply (rule set_iterator_rule_P [OF iteratei_rule, of S I σ0 c f P])
   apply simp_all
  done

  lemma iteratei_rule_insert_P:
    "⟦
      invar S;
      I {} σ0;
      !!x it σ. ⟦ c σ; x ∈ α S - it; it ⊆ α S; I it σ ⟧ ⟹ I (insert x it) (f x σ);
      !!σ. I (α S) σ ⟹ P σ;
      !!σ it. ⟦ it ⊆ α S; it ≠ α S; ¬ c σ; I it σ ⟧ ⟹ P σ
    ⟧ ⟹ P (iteratei S c f σ0)"
    apply (rule set_iterator_rule_insert_P [OF iteratei_rule, of S I σ0 c f P])
    apply simp_all
  done

  text {* Versions without break condition. *}
  lemma iterate_rule_P:
    "⟦
      invar S;
      I (α S) σ0;
      !!x it σ. ⟦ x ∈ it; it ⊆ α S; I it σ ⟧ ⟹ I (it - {x}) (f x σ);
      !!σ. I {} σ ⟹ P σ
    ⟧ ⟹ P (iteratei S (λ_. True) f σ0)"
   apply (rule set_iterator_no_cond_rule_P [OF iteratei_rule, of S I σ0 f P])
   apply simp_all
  done

  lemma iterate_rule_insert_P:
    "⟦
      invar S;
      I {} σ0;
      !!x it σ. ⟦ x ∈ α S - it; it ⊆ α S; I it σ ⟧ ⟹ I (insert x it) (f x σ);
      !!σ. I (α S) σ ⟹ P σ
    ⟧ ⟹ P (iteratei S (λ_. True) f σ0)"
    apply (rule set_iterator_no_cond_rule_insert_P [OF iteratei_rule, of S I σ0 f P])
    apply simp_all
  done
end

lemma set_iteratei_I :
assumes "⋀s. invar s ⟹ set_iterator (iti s) (α s)"
shows "set_iteratei α invar iti"
proof
  fix s 
  assume invar_s: "invar s"
  from assms(1)[OF invar_s] show it_OK: "set_iterator (iti s) (α s)" .
  
  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (α s)" .
qed
*)

type_synonym ('x,'s) set_list_it
  = "'s  ('x,'x list) set_iterator"
locale poly_set_iteratei_defs =
  fixes list_it :: "'s  ('x,'x list) set_iterator"
begin
  definition iteratei :: "'s  ('x,) set_iterator"
    where "iteratei S  it_to_it (list_it S)"
  (*local_setup {* Locale_Code.lc_decl_del @{term iteratei} *}*)

  abbreviation "iterate s  iteratei s (λ_. True)"
end

locale poly_set_iteratei =
  finite_set + poly_set_iteratei_defs list_it
  for list_it :: "'s  ('x,'x list) set_iterator" +
  constrains α :: "'s  'x set"
  assumes list_it_correct: "invar s  set_iterator (list_it s) (α s)"
begin
  lemma iteratei_correct: "invar S  set_iterator (iteratei S) (α S)"
    unfolding iteratei_def
    apply (rule it_to_it_correct)
    by (rule list_it_correct)

  lemma pi_iteratei[icf_proper_iteratorI]: 
    "proper_it (iteratei S) (iteratei S)"
    unfolding iteratei_def 
    by (intro icf_proper_iteratorI)

  lemma iteratei_rule_P:
    "
      invar S;
      I (α S) σ0;
      !!x it σ.  c σ; x  it; it  α S; I it σ   I (it - {x}) (f x σ);
      !!σ. I {} σ  P σ;
      !!σ it.  it  α S; it  {}; ¬ c σ; I it σ   P σ
      P (iteratei S c f σ0)"
   apply (rule set_iterator_rule_P [OF iteratei_correct, of S I σ0 c f P])
   apply simp_all
  done

  lemma iteratei_rule_insert_P:
    "
      invar S;
      I {} σ0;
      !!x it σ.  c σ; x  α S - it; it  α S; I it σ   I (insert x it) (f x σ);
      !!σ. I (α S) σ  P σ;
      !!σ it.  it  α S; it  α S; ¬ c σ; I it σ   P σ
      P (iteratei S c f σ0)"
    apply (rule 
      set_iterator_rule_insert_P[OF iteratei_correct, of S I σ0 c f P])
    apply simp_all
  done

  text ‹Versions without break condition.›
  lemma iterate_rule_P:
    "
      invar S;
      I (α S) σ0;
      !!x it σ.  x  it; it  α S; I it σ   I (it - {x}) (f x σ);
      !!σ. I {} σ  P σ
      P (iteratei S (λ_. True) f σ0)"
   apply (rule set_iterator_no_cond_rule_P [OF iteratei_correct, of S I σ0 f P])
   apply simp_all
  done

  lemma iterate_rule_insert_P:
    "
      invar S;
      I {} σ0;
      !!x it σ.  x  α S - it; it  α S; I it σ   I (insert x it) (f x σ);
      !!σ. I (α S) σ  P σ
      P (iteratei S (λ_. True) f σ0)"
    apply (rule set_iterator_no_cond_rule_insert_P [OF iteratei_correct, 
      of S I σ0 f P])
    apply simp_all
  done

end

subsection "More Set Operations"

subsubsection "Copy"
locale set_copy = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  +
  fixes copy :: "'s1  's2"
  assumes copy_correct: 
    "invar1 s1  α2 (copy s1) = α1 s1"
    "invar1 s1  invar2 (copy s1)"

subsubsection "Union"


locale set_union = s1: set α1 invar1 + s2: set α2 invar2 + s3: set α3 invar3
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  and α3 :: "'s3  'a set" and invar3
  +
  fixes union :: "'s1  's2  's3"
  assumes union_correct:
    "invar1 s1  invar2 s2  α3 (union s1 s2) = α1 s1  α2 s2"
    "invar1 s1  invar2 s2  invar3 (union s1 s2)"


locale set_union_dj = 
  s1: set α1 invar1 + s2: set α2 invar2 + s3: set α3 invar3
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  and α3 :: "'s3  'a set" and invar3
  +
  fixes union_dj :: "'s1  's2  's3"
  assumes union_dj_correct:
    "invar1 s1; invar2 s2; α1 s1  α2 s2 = {}  α3 (union_dj s1 s2) = α1 s1  α2 s2"
    "invar1 s1; invar2 s2; α1 s1  α2 s2 = {}  invar3 (union_dj s1 s2)"

locale set_union_list = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  +
  fixes union_list :: "'s1 list  's2"
  assumes union_list_correct:
    "s1set l. invar1 s1  α2 (union_list l) = {α1 s1 |s1. s1  set l}"
    "s1set l. invar1 s1  invar2 (union_list l)"

subsubsection "Difference"

locale set_diff = s1: set α1 invar1 + s2: set α2 invar2 
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  +
  fixes diff :: "'s1  's2  's1"
  assumes diff_correct:
    "invar1 s1  invar2 s2  α1 (diff s1 s2) = α1 s1 - α2 s2"
    "invar1 s1  invar2 s2  invar1 (diff s1 s2)"

subsubsection "Intersection"

locale set_inter = s1: set α1 invar1 + s2: set α2 invar2 + s3: set α3 invar3
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  and α3 :: "'s3  'a set" and invar3
  +
  fixes inter :: "'s1  's2  's3"
  assumes inter_correct:
    "invar1 s1  invar2 s2  α3 (inter s1 s2) = α1 s1  α2 s2"
    "invar1 s1  invar2 s2  invar3 (inter s1 s2)"

subsubsection "Subset"

locale set_subset = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  +
  fixes subset :: "'s1  's2  bool"
  assumes subset_correct:
    "invar1 s1  invar2 s2  subset s1 s2  α1 s1  α2 s2"

subsubsection "Equal"

locale set_equal = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  +
  fixes equal :: "'s1  's2  bool"
  assumes equal_correct:
    "invar1 s1  invar2 s2  equal s1 s2  α1 s1 = α2 s2"


subsubsection "Image and Filter"

locale set_image_filter = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'b set" and invar2
  +
  fixes image_filter :: "('a  'b option)  's1  's2"
  assumes image_filter_correct_aux:
    "invar1 s  α2 (image_filter f s) = { b . aα1 s. f a = Some b }"
    "invar1 s  invar2 (image_filter f s)"
begin
  ― ‹This special form will be checked first by the simplifier:›
  lemma image_filter_correct_aux2: 
    "invar1 s  
    α2 (image_filter (λx. if P x then (Some (f x)) else None) s) 
    = f ` {xα1 s. P x}"
    by (auto simp add: image_filter_correct_aux)

  lemmas image_filter_correct = 
    image_filter_correct_aux2 image_filter_correct_aux

end

locale set_inj_image_filter = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'b set" and invar2
  +
  fixes inj_image_filter :: "('a  'b option)  's1  's2"
  assumes inj_image_filter_correct:
    "invar1 s; inj_on f (α1 s  dom f)  α2 (inj_image_filter f s) = { b . aα1 s. f a = Some b }"
    "invar1 s; inj_on f (α1 s  dom f)  invar2 (inj_image_filter f s)"

subsubsection "Image"

locale set_image = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'b set" and invar2
  +
  fixes image :: "('a  'b)  's1  's2"
  assumes image_correct:
    "invar1 s  α2 (image f s) = f`α1 s"
    "invar1 s  invar2 (image f s)"


locale set_inj_image = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'b set" and invar2
  +
  fixes inj_image :: "('a  'b)  's1  's2"
  assumes inj_image_correct:
    "invar1 s; inj_on f (α1 s)  α2 (inj_image f s) = f`α1 s"
    "invar1 s; inj_on f (α1 s)  invar2 (inj_image f s)"


subsubsection "Filter"

locale set_filter = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  +
  fixes filter :: "('a  bool)  's1  's2"
  assumes filter_correct:
    "invar1 s  α2 (filter P s) = {e. e  α1 s  P e}"
    "invar1 s  invar2 (filter P s)"


subsubsection "Union of Set of Sets"

locale set_Union_image = 
  s1: set α1 invar1 + s2: set α2 invar2 + s3: set α3 invar3
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'b set" and invar2
  and α3 :: "'s3  'b set" and invar3
  +
  fixes Union_image :: "('a  's2)  's1  's3"
  assumes Union_image_correct: 
    " invar1 s; !!x. xα1 s  invar2 (f x)   
      α3 (Union_image f s) = (α2`f`α1 s)"
    " invar1 s; !!x. xα1 s  invar2 (f x)   invar3 (Union_image f s)"


subsubsection "Disjointness Check"

locale set_disjoint = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  +
  fixes disjoint :: "'s1  's2  bool"
  assumes disjoint_correct:
    "invar1 s1  invar2 s2  disjoint s1 s2  α1 s1  α2 s2 = {}"

subsubsection "Disjointness Check With Witness"

locale set_disjoint_witness = s1: set α1 invar1 + s2: set α2 invar2
  for α1 :: "'s1  'a set" and invar1
  and α2 :: "'s2  'a set" and invar2
  +
  fixes disjoint_witness :: "'s1  's2  'a option"
  assumes disjoint_witness_correct:
    "invar1 s1; invar2 s2 
       disjoint_witness s1 s2 = None  α1 s1  α2 s2 = {}"
    "invar1 s1; invar2 s2; disjoint_witness s1 s2 = Some a 
       aα1 s1  α2 s2"
begin
  lemma disjoint_witness_None: "invar1 s1; invar2 s2 
     disjoint_witness s1 s2 = None  α1 s1  α2 s2 = {}"
    by (case_tac "disjoint_witness s1 s2")
       (auto dest: disjoint_witness_correct)
    
  lemma disjoint_witnessI: "
    invar1 s1; 
    invar2 s2; 
    α1 s1  α2 s2  {}; 
    !!a. disjoint_witness s1 s2 = Some a  P 
                              P"
    by (case_tac "disjoint_witness s1 s2")
       (auto dest: disjoint_witness_correct)

end

subsubsection "Selection of Element"

locale set_sel = set +
  constrains α :: "'s  'x set"
  fixes sel :: "'s  ('x  'r option)  'r option"
  assumes selE: 
    " invar s; xα s; f x = Some r; 
       !!x r. sel s f = Some r; xα s; f x = Some r   Q 
       Q"
  assumes selI: "invar s; xα s. f x = None   sel s f = None"
begin

  lemma sel_someD:
    " invar s; sel s f = Some r; !!x. xα s; f x = Some r  P   P"
    apply (cases "xα s. r. f x = Some r")
    apply (safe)
    apply (erule_tac f=f and x=x in selE)
    apply auto
    apply (drule (1) selI)
    apply simp
    done

  lemma sel_noneD: 
    " invar s; sel s f = None; xα s   f x = None"
    apply (cases "xα s. r. f x = Some r")
    apply (safe)
    apply (erule_tac f=f and x=xa in selE)
    apply auto
    done
end

― ‹Selection of element (without mapping)›
locale set_sel' = set +
  constrains α :: "'s  'x set"
  fixes sel' :: "'s  ('x  bool)  'x option"
  assumes sel'E: 
    " invar s; xα s; P x; 
       !!x. sel' s P = Some x; xα s; P x   Q 
       Q"
  assumes sel'I: "invar s; xα s. ¬ P x   sel' s P = None"
begin

  lemma sel'_someD:
    " invar s; sel' s P = Some x   xα s  P x"
    apply (cases "xα s. P x")
    apply (safe)
    apply (erule_tac P=P and x=xa in sel'E)
    apply auto
    apply (erule_tac P=P and x=xa in sel'E)
    apply auto
    apply (drule (1) sel'I)
    apply simp
    apply (drule (1) sel'I)
    apply simp
    done

  lemma sel'_noneD: 
    " invar s; sel' s P = None; xα s   ¬P x"
    apply (cases "xα s. P x")
    apply (safe)
    apply (erule_tac P=P and x=xa in sel'E)
    apply auto
    done
end

subsubsection "Conversion of Set to List"

locale set_to_list = set +
  constrains α :: "'s  'x set"
  fixes to_list :: "'s  'x list"
  assumes to_list_correct: 
    "invar s  set (to_list s) = α s"
    "invar s  distinct (to_list s)"

subsubsection "Conversion of List to Set"

locale list_to_set = set +
  constrains α :: "'s  'x set"
  fixes to_set :: "'x list  's"
  assumes to_set_correct:
    "α (to_set l) = set l"
    "invar (to_set l)"

subsection "Ordered Sets"

  locale ordered_set = set α invar 
    for α :: "'s  ('u::linorder) set" and invar

  locale ordered_finite_set = finite_set α invar + ordered_set α invar
    for α :: "'s  ('u::linorder) set" and invar

subsubsection "Ordered Iteration"
  (* Deprecated *)
(*  locale set_iterateoi = ordered_finite_set α invar
    for α :: "'s ⇒ ('u::linorder) set" and invar
    +
    fixes iterateoi :: "'s ⇒ ('u,'σ) set_iterator"
    assumes iterateoi_rule: 
      "invar s ⟹ set_iterator_linord (iterateoi s) (α s)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (α m) σ0"
      assumes IP: "!!k it σ. ⟦ 
        c σ; 
        k ∈ it; 
        ∀j∈it. k≤j; 
        ∀j∈α m - it. j≤k; 
        it ⊆ α m; 
        I it σ 
      ⟧ ⟹ I (it - {k}) (f k σ)"
      assumes IF: "!!σ. I {} σ ⟹ P σ"
      assumes II: "!!σ it. ⟦ 
        it ⊆ α m; 
        it ≠ {}; 
        ¬ c σ; 
        I it σ; 
        ∀k∈it. ∀j∈α m - it. j≤k 
      ⟧ ⟹ P σ"
      shows "P (iterateoi m c f σ0)"  
    using set_iterator_linord_rule_P [OF iterateoi_rule, OF MINV, of I σ0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]: 
      assumes MINV: "invar m"
      assumes I0: "I ((α m)) σ0"
      assumes IP: "!!k it σ. ⟦ k ∈ it; ∀j∈it. k≤j; ∀j∈(α m) - it. j≤k; it ⊆ (α m); I it σ ⟧ 
                  ⟹ I (it - {k}) (f k σ)"
      assumes IF: "!!σ. I {} σ ⟹ P σ"
    shows "P (iterateoi m (λ_. True) f σ0)"
      apply (rule iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_iterateoi_I :
  assumes "⋀s. invar s ⟹ set_iterator_linord (itoi s) (α s)"
  shows "set_iterateoi α invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_linord (itoi s) (α s)" .
  
    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_linord_def]]
    show "finite (α s)" by simp 
  qed

  (* Deprecated *)
  locale set_reverse_iterateoi = ordered_finite_set α invar 
    for α :: "'s ⇒ ('u::linorder) set" and invar
    +
    fixes reverse_iterateoi :: "'s ⇒ ('u,'σ) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m ⟹ set_iterator_rev_linord (reverse_iterateoi m) (α m)" 
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I ((α m)) σ0"
      assumes IP: "!!k it σ. ⟦ 
        c σ; 
        k ∈ it; 
        ∀j∈it. k≥j; 
        ∀j∈(α m) - it. j≥k; 
        it ⊆ (α m); 
        I it σ 
      ⟧ ⟹ I (it - {k}) (f k σ)"
      assumes IF: "!!σ. I {} σ ⟹ P σ"
      assumes II: "!!σ it. ⟦ 
        it ⊆ (α m); 
        it ≠ {}; 
        ¬ c σ; 
        I it σ; 
        ∀k∈it. ∀j∈(α m) - it. j≥k 
      ⟧ ⟹ P σ"
    shows "P (reverse_iterateoi m c f σ0)"
    using set_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, OF MINV, of I σ0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I ((α m)) σ0"
      assumes IP: "!!k it σ. ⟦ 
        k ∈ it; 
        ∀j∈it. k≥j; 
        ∀j∈ (α m) - it. j≥k; 
        it ⊆ (α m); 
        I it σ 
      ⟧ ⟹ I (it - {k}) (f k σ)"
      assumes IF: "!!σ. I {} σ ⟹ P σ"
    shows "P (reverse_iterateoi m (λ_. True) f σ0)"
      apply (rule reverse_iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_reverse_iterateoi_I :
  assumes "⋀s. invar s ⟹ set_iterator_rev_linord (itoi s) (α s)"
  shows "set_reverse_iterateoi α invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_rev_linord (itoi s) (α s)" .
  
    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_rev_linord_def]]
    show "finite (α s)" by simp 
  qed
*)

locale poly_set_iterateoi_defs =
  fixes olist_it :: "'s  ('x,'x list) set_iterator"
begin
  definition iterateoi :: "'s  ('x,) set_iterator"
    where "iterateoi S  it_to_it (olist_it S)"
  (*local_setup {* Locale_Code.lc_decl_del @{term iterateoi} *}*)

  abbreviation "iterateo s  iterateoi s (λ_. True)"
end


locale poly_set_iterateoi =
  finite_set α invar + poly_set_iterateoi_defs list_ordered_it
  for α :: "'s  'x::linorder set" 
  and invar 
  and list_ordered_it :: "'s  ('x,'x list) set_iterator" +
  assumes list_ordered_it_correct: "invar x 
     set_iterator_linord (list_ordered_it x) (α x)"
begin
  lemma iterateoi_correct: 
    "invar S  set_iterator_linord (iterateoi S) (α S)"
    unfolding iterateoi_def
    apply (rule it_to_it_linord_correct)
    by (rule list_ordered_it_correct)

  lemma pi_iterateoi[icf_proper_iteratorI]: 
    "proper_it (iterateoi S) (iterateoi S)"
    unfolding iterateoi_def 
    by (intro icf_proper_iteratorI)
  
  lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar s"
    assumes I0: "I (α s) σ0"
    assumes IP: "!!k it σ.  
      c σ; 
      k  it; 
      jit. kj; 
      jα s - it. jk; 
      it  α s; 
      I it σ 
      I (it - {k}) (f k σ)"
    assumes IF: "!!σ. I {} σ  P σ"
    assumes II: "!!σ it.  
      it  α s; 
      it  {}; 
      ¬ c σ; 
      I it σ; 
      kit. jα s - it. jk 
      P σ"
    shows "P (iterateoi s c f σ0)"  
  using set_iterator_linord_rule_P [OF iterateoi_correct, 
    OF MINV, of I σ0 c f P, OF I0 _ IF] IP II
  by simp

  lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]: 
    assumes MINV: "invar s"
    assumes I0: "I ((α s)) σ0"
    assumes IP: "!!k it σ.  k  it; jit. kj; 
        j(α s) - it. jk; it  (α s); I it σ  
       I (it - {k}) (f k σ)"
    assumes IF: "!!σ. I {} σ  P σ"
  shows "P (iterateo s f σ0)"
    apply (rule iterateoi_rule_P [where I = I])
    apply (simp_all add: assms)
  done
end

locale poly_set_rev_iterateoi_defs =
  fixes list_rev_it :: "'s  ('x::linorder,'x list) set_iterator"
begin
  definition rev_iterateoi :: "'s  ('x,) set_iterator"
    where "rev_iterateoi S  it_to_it (list_rev_it S)"
  (*local_setup {* Locale_Code.lc_decl_del @{term rev_iterateoi} *}*)

  abbreviation "rev_iterateo m  rev_iterateoi m (λ_. True)"
  abbreviation "reverse_iterateoi  rev_iterateoi"
  abbreviation "reverse_iterateo  rev_iterateo"
end

locale poly_set_rev_iterateoi =
  finite_set α invar + poly_set_rev_iterateoi_defs list_rev_it
  for α :: "'s  'x::linorder set" 
  and invar
  and list_rev_it :: "'s  ('x,'x list) set_iterator" +
  assumes list_rev_it_correct: 
    "invar s  set_iterator_rev_linord (list_rev_it s) (α s)"
begin
  lemma rev_iterateoi_correct: 
    "invar S  set_iterator_rev_linord (rev_iterateoi S) (α S)"
    unfolding rev_iterateoi_def
    apply (rule it_to_it_rev_linord_correct)
    by (rule list_rev_it_correct)

  lemma pi_rev_iterateoi[icf_proper_iteratorI]: 
    "proper_it (rev_iterateoi S) (rev_iterateoi S)"
    unfolding rev_iterateoi_def 
    by (intro icf_proper_iteratorI)

  lemma rev_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar s"
    assumes I0: "I ((α s)) σ0"
    assumes IP: "!!k it σ.  
      c σ; 
      k  it; 
      jit. kj; 
      j(α s) - it. jk; 
      it  (α s); 
      I it σ 
      I (it - {k}) (f k σ)"
    assumes IF: "!!σ. I {} σ  P σ"
    assumes II: "!!σ it.  
      it  (α s); 
      it  {}; 
      ¬ c σ; 
      I it σ; 
      kit. j(α s) - it. jk 
      P σ"
  shows "P (rev_iterateoi s c f σ0)"
  using set_iterator_rev_linord_rule_P [OF rev_iterateoi_correct, 
    OF MINV, of I σ0 c f P, OF I0 _ IF] IP II
  by simp

  lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
    assumes MINV: "invar s"
    assumes I0: "I ((α s)) σ0"
    assumes IP: "!!k it σ.  
      k  it; 
      jit. kj; 
      j (α s) - it. jk; 
      it  (α s); 
      I it σ 
      I (it - {k}) (f k σ)"
    assumes IF: "!!σ. I {} σ  P σ"
  shows "P (rev_iterateo s f σ0)"
    apply (rule rev_iterateoi_rule_P [where I = I])
    apply (simp_all add: assms)
  done

end

subsubsection "Minimal and Maximal Element"

  locale set_min = ordered_set +
    constrains α :: "'s  'u::linorder set"
    fixes min :: "'s  ('u  bool)  'u option"
    assumes min_correct:
      " invar s; xα s; P x   min s P  Some ` {xα s. P x}"
      " invar s; xα s; P x   (the (min s P))  x"
      " invar s; {xα s. P x} = {}   min s P = None"
  begin
   lemma minE: 
     assumes A: "invar s" "xα s" "P x"
     obtains x' where
     "min s P = Some x'" "x'α s" "P x'" "xα s. P x  x'  x"
   proof -
     from min_correct(1)[of s x P, OF A] have 
       MIS: "min s P  Some ` {x  α s. P x}" .
     then obtain x' where KV: "min s P = Some x'" "x'α s" "P x'"
       by auto
     show thesis 
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule (1) min_correct(2)[OF invar s])
       apply (simp add: KV(1))
       done
   qed

   lemmas minI = min_correct(3)

   lemma min_Some:
     " invar s; min s P = Some x   xα s"
     " invar s; min s P = Some x   P x"
     " invar s; min s P = Some x; x'α s; P x'  xx'"
     apply -
     apply (cases "{x  α s. P x} = {}")
     apply (drule (1) min_correct(3))
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (2) min_correct(1)[of s _ P])
     apply auto [1]

     apply (cases "{x  α s. P x} = {}")
     apply (drule (1) min_correct(3))
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (2) min_correct(1)[of s _ P])
     apply auto [1]

     apply (drule (2) min_correct(2)[where P=P])
     apply auto
     done
     
   lemma min_None:
     " invar s; min s P = None   {xα s. P x} = {}"
     apply (cases "{xα s. P x} = {}")
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (2) min_correct(1)[where P=P])
     apply auto
     done

  end

  locale set_max = ordered_set +
    constrains α :: "'s  'u::linorder set"
    fixes max :: "'s  ('u  bool)  'u option"
    assumes max_correct:
      " invar s; xα s; P x   max s P  Some ` {xα s. P x}"
      " invar s; xα s; P x   the (max s P)  x"
      " invar s; {xα s. P x} = {}   max s P = None"
  begin
   lemma maxE: 
     assumes A: "invar s" "xα s" "P x"
     obtains x' where
     "max s P = Some x'" "x'α s" "P x'" "xα s. P x  x'  x"
   proof -
     from max_correct(1)[where P=P, OF A] have 
       MIS: "max s P  Some ` {xα s. P x}" .
     then obtain x' where KV: "max s P = Some x'" "x' α s" "P x'"
       by auto
     show thesis 
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule (1) max_correct(2)[OF invar s])
       apply (simp add: KV(1))
       done
   qed

   lemmas maxI = max_correct(3)

   lemma max_Some:
     " invar s; max s P = Some x   xα s"
     " invar s; max s P = Some x   P x"
     " invar s; max s P = Some x; x'α s; P x'  xx'"
     apply -
     apply (cases "{xα s. P x} = {}")
     apply (drule (1) max_correct(3))
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (2) max_correct(1)[of s _ P])
     apply auto [1]

     apply (cases "{xα s. P x} = {}")
     apply (drule (1) max_correct(3))
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (2) max_correct(1)[of s _ P])
     apply auto [1]

     apply (drule (1) max_correct(2)[where P=P])
     apply auto
     done
     
   lemma max_None:
     " invar s; max s P = None   {xα s. P x} = {}"
     apply (cases "{xα s. P x} = {}")
     apply simp
     apply simp
     apply (erule exE)
     apply clarify
     apply (drule (1) max_correct(1)[where P=P])
     apply auto
     done

  end

subsection "Conversion to List"
  locale set_to_sorted_list = ordered_set + 
  constrains α :: "'s  'x::linorder set"
  fixes to_sorted_list :: "'s  'x list"
  assumes to_sorted_list_correct: 
    "invar s  set (to_sorted_list s) = α s"
    "invar s  distinct (to_sorted_list s)"
    "invar s  sorted (to_sorted_list s)"

  locale set_to_rev_list = ordered_set + 
  constrains α :: "'s  'x::linorder set"
  fixes to_rev_list :: "'s  'x list"
  assumes to_rev_list_correct: 
    "invar s  set (to_rev_list s) = α s"
    "invar s  distinct (to_rev_list s)"
    "invar s  sorted (rev (to_rev_list s))"

subsection "Record Based Interface"
  record ('x,'s) set_ops = 
    set_op_α :: "'s  'x set"
    set_op_invar :: "'s  bool"
    set_op_empty :: "unit  's"
    set_op_memb :: "'x  's  bool"
    set_op_ins :: "'x  's  's"
    set_op_ins_dj :: "'x  's  's"
    set_op_delete :: "'x  's  's"
    set_op_list_it :: "('x,'s) set_list_it"
    set_op_sng :: "'x  's"
    set_op_isEmpty :: "'s  bool"
    set_op_isSng :: "'s  bool"
    set_op_ball :: "'s  ('x  bool)  bool"
    set_op_bex :: "'s  ('x  bool)  bool"
    set_op_size :: "'s  nat"
    set_op_size_abort :: "nat  's  nat"
    set_op_union :: "'s  's  's"
    set_op_union_dj :: "'s  's  's"
    set_op_diff :: "'s  's  's"
    set_op_filter :: "('x  bool)  's  's"
    set_op_inter :: "'s  's  's"
    set_op_subset :: "'s  's  bool"
    set_op_equal :: "'s  's  bool"
    set_op_disjoint :: "'s  's  bool"
    set_op_disjoint_witness :: "'s  's  'x option"
    set_op_sel :: "'s  ('x  bool)  'x option" ― ‹Version without mapping›
    set_op_to_list :: "'s  'x list"
    set_op_from_list :: "'x list  's"

  locale StdSetDefs = 
    poly_set_iteratei_defs "set_op_list_it ops"
    for ops :: "('x,'s,'more) set_ops_scheme"
  begin
    abbreviation α where "α == set_op_α ops"
    abbreviation invar where "invar == set_op_invar ops"
    abbreviation empty where "empty == set_op_empty ops"
    abbreviation memb where "memb == set_op_memb ops"
    abbreviation ins where "ins == set_op_ins ops"
    abbreviation ins_dj where "ins_dj == set_op_ins_dj ops"
    abbreviation delete where "delete == set_op_delete ops"
    abbreviation list_it where "list_it  set_op_list_it ops"
    abbreviation sng where "sng == set_op_sng ops"
    abbreviation isEmpty where "isEmpty == set_op_isEmpty ops"
    abbreviation isSng where "isSng == set_op_isSng ops"
    abbreviation ball where "ball == set_op_ball ops"
    abbreviation bex where "bex == set_op_bex ops"
    abbreviation size where "size == set_op_size ops"
    abbreviation size_abort where "size_abort == set_op_size_abort ops"
    abbreviation union where "union == set_op_union ops"
    abbreviation union_dj where "union_dj == set_op_union_dj ops"
    abbreviation diff where "diff == set_op_diff ops"
    abbreviation filter where "filter == set_op_filter ops"
    abbreviation inter where "inter == set_op_inter ops"
    abbreviation subset where "subset == set_op_subset ops"
    abbreviation equal where "equal == set_op_equal ops"
    abbreviation disjoint where "disjoint == set_op_disjoint ops"
    abbreviation disjoint_witness 
      where "disjoint_witness == set_op_disjoint_witness ops"
    abbreviation sel where "sel == set_op_sel ops"
    abbreviation to_list where "to_list == set_op_to_list ops"
    abbreviation from_list where "from_list == set_op_from_list ops"
  end

  locale StdSet = StdSetDefs ops +
    set α invar +
    set_empty α invar empty + 
    set_memb α invar memb + 
    set_ins α invar ins + 
    set_ins_dj α invar ins_dj +
    set_delete α invar delete + 
    poly_set_iteratei α invar list_it +
    set_sng α invar sng + 
    set_isEmpty α invar isEmpty + 
    set_isSng α invar isSng + 
    set_ball α invar ball + 
    set_bex α invar bex + 
    set_size α invar size + 
    set_size_abort α invar size_abort + 
    set_union α invar α invar α invar union + 
    set_union_dj α invar α invar α invar union_dj + 
    set_diff α invar α invar diff + 
    set_filter α invar α invar filter +  
    set_inter α invar α invar α invar inter + 
    set_subset α invar α invar subset + 
    set_equal α invar α invar equal + 
    set_disjoint α invar α invar disjoint + 
    set_disjoint_witness α invar α invar disjoint_witness + 
    set_sel' α invar sel + 
    set_to_list α invar to_list + 
    list_to_set α invar from_list
    for ops :: "('x,'s,'more) set_ops_scheme"
  begin

    lemmas correct = 
      empty_correct
      sng_correct
      memb_correct
      ins_correct
      ins_dj_correct
      delete_correct
      isEmpty_correct
      isSng_correct
      ball_correct
      bex_correct
      size_correct
      size_abort_correct
      union_correct
      union_dj_correct
      diff_correct
      filter_correct
      inter_correct
      subset_correct
      equal_correct
      disjoint_correct
      disjoint_witness_correct
      to_list_correct
      to_set_correct

  end

  lemmas StdSet_intro = StdSet.intro[rem_dup_prems]

  locale StdSet_no_invar = StdSet + set_no_invar α invar

  record ('x,'s) oset_ops = "('x::linorder,'s) set_ops" +
    set_op_ordered_list_it :: "'s  ('x,'x list) set_iterator"
    set_op_rev_list_it :: "'s  ('x,'x list) set_iterator"
    set_op_min :: "'s  ('x  bool)  'x option"
    set_op_max :: "'s  ('x  bool)  'x option"
    set_op_to_sorted_list :: "'s  'x list"
    set_op_to_rev_list :: "'s  'x list"
    
  locale StdOSetDefs = StdSetDefs ops
    + poly_set_iterateoi_defs "set_op_ordered_list_it ops"
    + poly_set_rev_iterateoi_defs "set_op_rev_list_it ops"
    for ops :: "('x::linorder,'s,'more) oset_ops_scheme"
  begin
    abbreviation "ordered_list_it  set_op_ordered_list_it ops"
    abbreviation "rev_list_it  set_op_rev_list_it ops"
    abbreviation min where "min == set_op_min ops"
    abbreviation max where "max == set_op_max ops"
    abbreviation to_sorted_list where 
      "to_sorted_list  set_op_to_sorted_list ops"
    abbreviation to_rev_list where "to_rev_list  set_op_to_rev_list ops"
  end

  locale StdOSet =
    StdOSetDefs ops +
    StdSet ops +
    poly_set_iterateoi α invar ordered_list_it +
    poly_set_rev_iterateoi α invar rev_list_it +
    set_min α invar min +
    set_max α invar max +
    set_to_sorted_list α invar to_sorted_list +
    set_to_rev_list α invar to_rev_list
    for ops :: "('x::linorder,'s,'more) oset_ops_scheme"
  begin
  end

  lemmas StdOSet_intro =
    StdOSet.intro[OF StdSet_intro, rem_dup_prems]

no_notation insert ("set'_ins")
(*notation member (infixl "mem" 55)*)

end

Theory ListSpec

section ‹\isaheader{Specification of Sequences}›
theory ListSpec 
imports ICF_Spec_Base
begin

(*@intf List
  @abstype 'a list
  This interface specifies sequences.
*)

subsection "Definition"
locale list =
  ― ‹Abstraction to HOL-lists›
  fixes α :: "'s  'x list"
  ― ‹Invariant›
  fixes invar :: "'s  bool"

locale list_no_invar = list +
  assumes invar[simp, intro!]: "l. invar l"

subsection "Functions"

locale list_empty = list +
  constrains α :: "'s  'x list"
  fixes empty :: "unit  's"
  assumes empty_correct:
    "α (empty ()) = []"
    "invar (empty ())"


locale list_isEmpty = list +
  constrains α :: "'s  'x list"
  fixes isEmpty :: "'s  bool"
  assumes isEmpty_correct:
    "invar s  isEmpty s  α s = []"

locale poly_list_iteratei = list +
  constrains α :: "'s  'x list"
begin  
  definition iteratei where
    iteratei_correct[code_unfold]: "iteratei s  foldli (α s)"
  definition iterate where
    iterate_correct[code_unfold]: "iterate s  foldli (α s) (λ_. True)"
end

locale poly_list_rev_iteratei = list +
  constrains α :: "'s  'x list"
begin  
  definition rev_iteratei where
    rev_iteratei_correct[code_unfold]: "rev_iteratei s  foldri (α s)"
  definition rev_iterate where
    rev_iterate_correct[code_unfold]: "rev_iterate s  foldri (α s) (λ_. True)"
end

(*
locale list_iteratei = list +
  constrains α :: "'s ⇒ 'x list"
  fixes iteratei :: "'s ⇒ ('x,'σ) set_iterator"
  assumes iteratei_correct:
    "invar s ⟹ iteratei s = foldli (α s)"
begin
  lemma iteratei_no_sel_rule:
    "invar s ⟹ distinct (α s) ⟹ set_iterator (iteratei s) (set (α s))"
    by (simp add: iteratei_correct set_iterator_foldli_correct)
end

lemma list_iteratei_iteratei_linord_rule:
  "list_iteratei α invar iteratei ⟹ invar s ⟹ distinct (α s) ⟹ sorted (α s) ⟹
   set_iterator_linord (iteratei s) (set (α s))"
  by (simp add: list_iteratei_def set_iterator_linord_foldli_correct)

lemma list_iteratei_iteratei_rev_linord_rule:
  "list_iteratei α invar iteratei ⟹ invar s ⟹ distinct (α s) ⟹ sorted (rev (α s)) ⟹
   set_iterator_rev_linord (iteratei s) (set (α s))"
  by (simp add: list_iteratei_def set_iterator_rev_linord_foldli_correct)


locale list_reverse_iteratei = list +
  constrains α :: "'s ⇒ 'x list"
  fixes reverse_iteratei :: "'s ⇒ ('x,'σ) set_iterator"
  assumes reverse_iteratei_correct:
    "invar s ⟹ reverse_iteratei s = foldri (α s)"
begin
  lemma reverse_iteratei_no_sel_rule:
    "invar s ⟹ distinct (α s) ⟹ set_iterator (reverse_iteratei s) (set (α s))"
    by (simp add: reverse_iteratei_correct set_iterator_foldri_correct)
end

lemma list_reverse_iteratei_iteratei_linord_rule:
  "list_reverse_iteratei α invar iteratei ⟹ invar s ⟹ distinct (α s) ⟹ sorted (rev (α s)) ⟹
   set_iterator_linord (iteratei s) (set (α s))"
  by (simp add: list_reverse_iteratei_def set_iterator_linord_foldri_correct)

lemma list_reverse_iteratei_iteratei_rev_linord_rule:
  "list_reverse_iteratei α invar iteratei ⟹ invar s ⟹ distinct (α s) ⟹ sorted (α s) ⟹
   set_iterator_rev_linord (iteratei s) (set (α s))"
  by (simp add: list_reverse_iteratei_def set_iterator_rev_linord_foldri_correct)
*)

locale list_size = list +
  constrains α :: "'s  'x list"
  fixes size :: "'s  nat"
  assumes size_correct:
    "invar s  size s = length (α s)"
  
locale list_appendl = list +
  constrains α :: "'s  'x list"
  fixes appendl :: "'x  's  's"
  assumes appendl_correct:
    "invar s  α (appendl x s) = x#α s"
    "invar s  invar (appendl x s)"
begin
  abbreviation (input) "push  appendl" 
  lemmas push_correct = appendl_correct
end

locale list_removel = list +
  constrains α :: "'s  'x list"
  fixes removel :: "'s  ('x × 's)"
  assumes removel_correct:
    "invar s; α s  []  fst (removel s) = hd (α s)"
    "invar s; α s  []  α (snd (removel s)) = tl (α s)"
    "invar s; α s  []  invar (snd (removel s))"
begin
  lemma removelE: 
    assumes I: "invar s" "α s  []" 
    obtains s' where "removel s = (hd (α s), s')" "invar s'" "α s' = tl (α s)"
  proof -
    from removel_correct(1,2,3)[OF I] have 
      C: "fst (removel s) = hd (α s)"
         "α (snd (removel s)) = tl (α s)"
         "invar (snd (removel s))" .
    from that[of "snd (removel s)", OF _ C(3,2), folded C(1)] show thesis
      by simp
  qed


  text ‹The following shortcut notations are not meant for generating efficient code,
    but solely to simplify reasoning›
  (* TODO: Is this actually used somewhere ? *)
  (*
  definition "head s == fst (removef s)"
  definition "tail s == snd (removef s)"

  lemma tail_correct: "⟦invar F; α F ≠ []⟧ ⟹ α (tail F) = tl (α F)"
    by (simp add: tail_def removef_correct)

  lemma head_correct: "⟦invar F; α F ≠ []⟧ ⟹ (head F) = hd (α F)"
    by (simp add: head_def removef_correct)

  lemma removef_split: "removef F = (head F, tail F)"
    apply (cases "removef F")
    apply (simp add: head_def tail_def)
    done
    *)
      
  abbreviation (input) "pop  removel"
  lemmas pop_correct = removel_correct

  abbreviation (input) "dequeue  removel"
  lemmas dequeue_correct = removel_correct
end

locale list_leftmost = list +
  constrains α :: "'s  'x list"
  fixes leftmost :: "'s  'x"
  assumes leftmost_correct:
    "invar s; α s  []  leftmost s = hd (α s)"
begin
  abbreviation (input) top where "top  leftmost"
  lemmas top_correct = leftmost_correct
end

locale list_appendr = list +
  constrains α :: "'s  'x list"
  fixes appendr :: "'x  's  's"
  assumes appendr_correct: 
    "invar s  α (appendr x s) = α s @ [x]"
    "invar s  invar (appendr x s)"
begin
  abbreviation (input) "enqueue  appendr"
  lemmas enqueue_correct = appendr_correct
end

locale list_remover = list +
  constrains α :: "'s  'x list"
  fixes remover :: "'s  's × 'x"
  assumes remover_correct: 
    "invar s; α s  []  α (fst (remover s)) = butlast (α s)"
    "invar s; α s  []  snd (remover s) = last (α s)"
    "invar s; α s  []  invar (fst (remover s))"

locale list_rightmost = list +
  constrains α :: "'s  'x list"
  fixes rightmost :: "'s  'x"
  assumes rightmost_correct:
    "invar s; α s  []  rightmost s = List.last (α s)"
begin
  abbreviation (input) bot where "bot  rightmost"
  lemmas bot_correct = rightmost_correct
end

subsubsection "Indexing"
locale list_get = list +
  constrains α :: "'s  'x list"
  fixes get :: "'s  nat  'x"
  assumes get_correct:
    "invar s; i<length (α s)  get s i = α s ! i"

locale list_set = list +
  constrains α :: "'s  'x list"
  fixes set :: "'s  nat  'x  's"
  assumes set_correct:
    "invar s; i<length (α s)  α (set s i x) = (α s) [i := x]"
    "invar s; i<length (α s)  invar (set s i x)"

record ('a,'s) list_ops = 
  list_op_α :: "'s  'a list"
  list_op_invar :: "'s  bool"
  list_op_empty :: "unit  's"
  list_op_isEmpty :: "'s  bool"
  list_op_size :: "'s  nat"
  list_op_appendl :: "'a  's  's"
  list_op_removel :: "'s  'a × 's"
  list_op_leftmost :: "'s  'a"
  list_op_appendr :: "'a  's  's"
  list_op_remover :: "'s  's × 'a"
  list_op_rightmost :: "'s  'a"
  list_op_get :: "'s  nat  'a"
  list_op_set :: "'s  nat  'a  's"

locale StdListDefs = 
  poly_list_iteratei "list_op_α ops" "list_op_invar ops"
  + poly_list_rev_iteratei "list_op_α ops" "list_op_invar ops"
  for ops :: "('a,'s,'more) list_ops_scheme"
begin
  abbreviation α where "α  list_op_α ops"
  abbreviation invar where "invar  list_op_invar ops"
  abbreviation empty where "empty  list_op_empty ops"
  abbreviation isEmpty where "isEmpty  list_op_isEmpty ops"
  abbreviation size where "size  list_op_size ops"
  abbreviation appendl where "appendl  list_op_appendl ops"
  abbreviation removel where "removel  list_op_removel ops"
  abbreviation leftmost where "leftmost  list_op_leftmost ops"
  abbreviation appendr where "appendr  list_op_appendr ops"
  abbreviation remover where "remover  list_op_remover ops"
  abbreviation rightmost where "rightmost  list_op_rightmost ops"
  abbreviation get where "get  list_op_get ops"
  abbreviation set where "set  list_op_set ops"
end

locale StdList = StdListDefs ops
  + list α invar
  + list_empty α invar empty 
  + list_isEmpty α invar isEmpty 
  + list_size α invar size 
  + list_appendl α invar appendl 
  + list_removel α invar removel 
  + list_leftmost α invar leftmost 
  + list_appendr α invar appendr 
  + list_remover α invar remover 
  + list_rightmost α invar rightmost 
  + list_get α invar get 
  + list_set α invar set 
  for ops :: "('a,'s,'more) list_ops_scheme"
begin
  lemmas correct = 
    empty_correct
    isEmpty_correct
    size_correct
    appendl_correct
    removel_correct
    leftmost_correct
    appendr_correct
    remover_correct
    rightmost_correct
    get_correct
    set_correct

end

locale StdList_no_invar = StdList + list_no_invar α invar
    
end

Theory AnnotatedListSpec

section ‹\isaheader{Specification of Annotated Lists}›
theory AnnotatedListSpec
imports ICF_Spec_Base
begin

(*@intf AnnotatedList
  @abstype ('e × 'a::monoid_add) list
  Lists with annotated elements. The annotations form a monoid, and there is
  a split operation to split the list according to its annotations. This is the
  abstract concept implemented by finger trees.
*)

subsection "Introduction"
text ‹
  We define lists with annotated elements. The annotations form a monoid.

  We provide standard list operations and the split-operation, that
  splits the list according to its annotations.
›
locale al =
  ― ‹Annotated lists are abstracted to lists of pairs of elements and annotations.›
  fixes α :: "'s  ('e × 'a::monoid_add) list"
  fixes invar :: "'s  bool"
  
locale al_no_invar = al +
  assumes invar[simp, intro!]: "l. invar l"

subsection "Basic Annotated List Operations"

subsubsection "Empty Annotated List"
locale al_empty = al +
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes empty :: "unit  's"
  assumes empty_correct: 
    "invar (empty ())" 
    "α (empty ()) = Nil" 

subsubsection "Emptiness Check"
locale al_isEmpty = al + 
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes isEmpty :: "'s  bool"
  assumes isEmpty_correct: 
    "invar s  isEmpty s  α s = Nil" 

subsubsection "Counting Elements"
locale al_count = al + 
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes count :: "'s  nat"
  assumes count_correct: 
    "invar s  count s = length(α s)" 

subsubsection "Appending an Element from the Left"
locale al_consl = al +
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes consl :: "'e  'a  's  's"
  assumes consl_correct:
    "invar s  invar (consl e a s)"
    "invar s  (α (consl e a s)) = (e,a) # (α s)"

subsubsection "Appending an Element from the Right"
locale al_consr = al +
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes consr :: "'s  'e  'a  's"
  assumes consr_correct:
    "invar s  invar (consr s e a)"
    "invar s  (α (consr s e a)) = (α s) @ [(e,a)]"
  
subsubsection "Take the First Element"
locale al_head = al + 
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes head :: "'s  ('e × 'a)"
  assumes head_correct:
    "invar s; α s  Nil  head s = hd (α s)"

subsubsection "Drop the First Element"
locale al_tail = al + 
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes tail :: "'s  's"
  assumes tail_correct:
    "invar s; α s  Nil  α (tail s) = tl (α s)"
    "invar s; α s  Nil  invar (tail s)"

subsubsection "Take the Last Element"
locale al_headR = al + 
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes headR :: "'s  ('e × 'a)"
  assumes headR_correct:
    "invar s; α s  Nil  headR s = last (α s)"

subsubsection "Drop the Last Element"
locale al_tailR = al +   
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes tailR :: "'s  's"
  assumes tailR_correct:
    "invar s; α s  Nil  α (tailR s) = butlast (α s)"
    "invar s; α s  Nil  invar (tailR s)"

subsubsection "Fold a Function over the Elements from the Left"
locale al_foldl = al + 
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes foldl :: "('z  'e × 'a  'z)  'z  's  'z"
  assumes foldl_correct:
    "invar s  foldl f σ s = List.foldl f σ (α s)"

subsubsection "Fold a Function over the Elements from the Right"
locale al_foldr = al + 
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes foldr :: "('e × 'a  'z  'z)  's  'z  'z"
  assumes foldr_correct:
    "invar s  foldr f s σ = List.foldr f (α s) σ"

locale poly_al_fold = al +
  constrains α :: "'s  ('e × 'a::monoid_add) list"
begin
  definition foldl where 
    foldl_correct[code_unfold]: "foldl f σ s = List.foldl f σ (α s)"
  definition foldr where 
    foldr_correct[code_unfold]: "foldr f s σ = List.foldr f (α s) σ"
end
    
subsubsection "Concatenation of Two Annotated Lists"
locale al_app = al +
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes app :: "'s  's  's"
  assumes app_correct:
    "invar s;invar s'  α (app s s') = (α s) @ (α s')"
    "invar s;invar s'  invar (app s s')"

subsubsection "Readout the Summed up Annotations"
locale al_annot = al +
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes annot :: "'s  'a"
  assumes annot_correct:
    "invar s  (annot s) = (sum_list (map snd (α s)))"

subsubsection "Split by Monotone Predicate"
locale al_splits = al + 
  constrains α :: "'s  ('e × 'a::monoid_add) list"
  fixes splits :: "('a  bool)  'a  's  
                                ('s × ('e × 'a) × 's)"
  assumes splits_correct:
    "invar s;
       a b. p a  p (a + b);
       ¬ p i; 
       p (i + sum_list (map snd (α s)));
       (splits p i s) = (l, (e,a), r) 
       
        (α s) = (α l) @ (e,a) # (α r)  
        ¬ p (i + sum_list (map snd (α l)))  
        p (i + sum_list (map snd (α l)) + a)  
        invar l  
        invar r
    "
begin
  lemma splitsE:
    assumes 
    invar: "invar s" and
    mono: "a b. p a  p (a + b)" and
    init_ff: "¬ p i" and
    sum_tt: "p (i + sum_list (map snd (α s)))"
    obtains l e a r where
    "(splits p i s) = (l, (e,a), r)"
    "(α s) = (α l) @ (e,a) # (α r)"
    "¬ p (i + sum_list (map snd (α l)))"
    "p (i + sum_list (map snd (α l)) + a)"
    "invar l"
    "invar r"
    using assms
    apply (cases "splits p i s")
    apply (case_tac b)
    apply (drule_tac i = i and p = p 
      and l = a and r = c and e = aa and a = ba in  splits_correct)
    apply (simp_all)
    done
end    

subsection "Record Based Interface"
record ('e,'a,'s) alist_ops =
  alist_op_α ::"'s  ('e × 'a::monoid_add) list"
  alist_op_invar :: "'s  bool"
  alist_op_empty :: "unit  's"
  alist_op_isEmpty :: "'s  bool"
  alist_op_count :: "'s  nat"
  alist_op_consl :: "'e  'a  's  's"
  alist_op_consr :: "'s  'e  'a  's"
  alist_op_head :: "'s  ('e × 'a)"
  alist_op_tail :: "'s  's"
  alist_op_headR :: "'s  ('e × 'a)"
  alist_op_tailR :: "'s  's"
  alist_op_app :: "'s  's  's"
  alist_op_annot :: "'s  'a"
  alist_op_splits :: "('a  bool)  'a  's  ('s × ('e × 'a) × 's)"

locale StdALDefs = poly_al_fold "alist_op_α ops" "alist_op_invar ops"
  for ops :: "('e,'a::monoid_add,'s,'more) alist_ops_scheme"
begin
  abbreviation α where "α == alist_op_α ops"
  abbreviation invar where "invar == alist_op_invar ops "
  abbreviation empty where "empty == alist_op_empty ops "
  abbreviation isEmpty where "isEmpty == alist_op_isEmpty ops "
  abbreviation count where "count == alist_op_count ops"
  abbreviation consl where "consl == alist_op_consl ops "
  abbreviation consr where "consr == alist_op_consr ops "
  abbreviation head where "head == alist_op_head ops "
  abbreviation tail where "tail == alist_op_tail ops "
  abbreviation headR where "headR == alist_op_headR ops "
  abbreviation tailR where "tailR == alist_op_tailR ops "
  abbreviation app where "app == alist_op_app ops "
  abbreviation annot where "annot == alist_op_annot ops "
  abbreviation splits where "splits == alist_op_splits ops "
end

locale StdAL = StdALDefs ops +
  al α invar +
  al_empty α invar empty +
  al_isEmpty α invar isEmpty +
  al_count α invar count +
  al_consl α invar consl +
  al_consr α invar consr +
  al_head α invar head +
  al_tail α invar tail +
  al_headR α invar headR +
  al_tailR α invar tailR +
  al_app α invar app +
  al_annot α invar annot +
  al_splits α invar splits
  for ops
begin
  lemmas correct =
    empty_correct 
    isEmpty_correct
    count_correct
    consl_correct
    consr_correct
    head_correct
    tail_correct
    headR_correct
    tailR_correct
    app_correct
    annot_correct      
    foldl_correct
    foldr_correct
end

locale StdAL_no_invar = StdAL + al_no_invar α invar


end

Theory PrioSpec

section ‹\isaheader{Specification of Priority Queues}›
theory PrioSpec
imports ICF_Spec_Base "HOL-Library.Multiset"
begin

(*@intf Prio
  @abstype ('e × 'a::linorder) multiset
  Priority queues that may contain duplicate elements.
*)

text ‹
  We specify priority queues, that are abstracted to
  multisets of pairs of elements and priorities.
›

locale prio = 
  fixes α :: "'p  ('e × 'a::linorder) multiset" ― ‹Abstraction to multiset›
  fixes invar :: "'p  bool"                     ― ‹Invariant›

locale prio_no_invar = prio +
  assumes invar[simp, intro!]: "s. invar s"

subsection "Basic Priority Queue Functions"
subsubsection "Empty Queue"
locale prio_empty = prio +
  constrains α :: "'p  ('e × 'a::linorder) multiset"
  fixes empty :: "unit  'p"
  assumes empty_correct: 
  "invar (empty ())" 
  "α (empty ()) = {#}"


subsubsection "Emptiness Predicate"
locale prio_isEmpty = prio +
  constrains α :: "'p  ('e × 'a::linorder) multiset"
  fixes isEmpty :: "'p  bool"
  assumes isEmpty_correct: 
  "invar p  (isEmpty p) = (α p = {#})" 


subsubsection "Find Minimal Element"
locale prio_find = prio +
  constrains α :: "'p  ('e × 'a::linorder) multiset"
  fixes find :: "'p  ('e × 'a::linorder)"
  assumes find_correct: "invar p; α p  {#}  
       (find p) ∈# (α p)  (y  set_mset (α p). snd (find p)  snd y)"

subsubsection "Insert"
locale prio_insert = prio +
  constrains α :: "'p  ('e × 'a::linorder) multiset"
  fixes insert :: "'e  'a  'p  'p"
  assumes insert_correct: 
  "invar p  invar (insert e a p)"
  "invar p  α (insert e a p) = (α p) + {#(e,a)#}" 

subsubsection "Meld Two Queues"
locale prio_meld = prio +
  constrains α :: "'p  ('e × 'a::linorder) multiset"
  fixes meld :: "'p  'p  'p"
  assumes meld_correct:
  "invar p; invar p'  invar (meld p p')"
  "invar p; invar p'  α (meld p p') = (α p) + (α p')"

subsubsection "Delete Minimal Element"
text ‹Delete the same element that find will return›
locale prio_delete = prio_find +
  constrains α :: "'p  ('e × 'a::linorder) multiset"
  fixes delete :: "'p  'p"
  assumes delete_correct:
  "invar p; α p  {#}  invar (delete p)"
  "invar p; α p  {#}  α (delete p) = (α p) - {# (find p) #}"


subsection "Record based interface"
record ('e, 'a, 'p) prio_ops =
  prio_op_α :: "'p  ('e × 'a) multiset" 
  prio_op_invar :: "'p  bool" 
  prio_op_empty :: "unit  'p" 
  prio_op_isEmpty :: "'p  bool" 
  prio_op_insert :: "'e  'a  'p  'p" 
  prio_op_find :: "'p  'e × 'a" 
  prio_op_delete :: "'p  'p" 
  prio_op_meld :: "'p  'p  'p"

locale StdPrioDefs =
  fixes ops :: "('e,'a::linorder,'p) prio_ops"
begin
  abbreviation α where "α == prio_op_α ops"
  abbreviation invar where "invar == prio_op_invar ops"
  abbreviation empty where "empty == prio_op_empty ops"
  abbreviation isEmpty where "isEmpty == prio_op_isEmpty ops"
  abbreviation insert where "insert == prio_op_insert ops"
  abbreviation find where "find == prio_op_find ops"
  abbreviation delete where "delete == prio_op_delete ops"
  abbreviation meld where "meld == prio_op_meld ops"
end

locale StdPrio = StdPrioDefs ops +
  prio α invar +
  prio_empty α invar empty +
  prio_isEmpty α invar isEmpty +
  prio_find α invar find +
  prio_insert α invar insert +
  prio_meld α invar meld +
  prio_delete α invar find delete
  for ops
begin
  lemmas correct =
    empty_correct
    isEmpty_correct
    find_correct
    insert_correct
    meld_correct
    delete_correct
end

locale StdPrio_no_invar = StdPrio + prio_no_invar α invar

end

Theory PrioUniqueSpec

section ‹\isaheader{Specification of Unique Priority Queues}›
theory PrioUniqueSpec
imports ICF_Spec_Base
begin

(*@intf PrioUnique
  @abstype ('e ⇀ 'a::linorder)
  Priority queues without duplicate elements. This interface defines a
  decrease-key operation.
*)

text ‹
  We define unique priority queues, where each element may occur at most once.
  We provide operations to get and remove the element with the minimum priority,
  as well as to access and change an elements priority (decrease-key operation).

  Unique priority queues are abstracted to maps from elements to priorities.
›
locale uprio =  
  fixes α :: "'s  ('e  'a::linorder)" 
  fixes invar :: "'s  bool"                     

locale uprio_no_invar = uprio +
  assumes invar[simp, intro!]: "s. invar s"
  
locale uprio_finite = uprio +
  assumes finite_correct: 
  "invar s  finite (dom (α s))"

subsection "Basic Upriority Queue Functions"

subsubsection "Empty Queue"
locale uprio_empty = uprio +
  constrains α :: "'s  ('e  'a::linorder)"
  fixes empty :: "unit  's"
  assumes empty_correct: 
  "invar (empty ())" 
  "α (empty ()) = Map.empty"

subsubsection "Emptiness Predicate"
locale uprio_isEmpty = uprio +
  constrains α :: "'s  ('e  'a::linorder)"
  fixes isEmpty :: "'s  bool"
  assumes isEmpty_correct: 
  "invar s  (isEmpty s) = (α s = Map.empty)" 

subsubsection "Find and Remove Minimal Element"
locale uprio_pop = uprio +
  constrains α :: "'s  ('e  'a::linorder)"
  fixes pop :: "'s  ('e × 'a × 's)"
  assumes pop_correct:
  "invar s; α s  Map.empty; pop s = (e,a,s')  
    invar s'  
    α s' = (α s)(e := None)  
    (α s) e = Some a  
    (y  ran (α s). a  y)"
begin

  lemma popE: 
    assumes 
    "invar s" 
    "α s  Map.empty" 
    obtains e a s' where 
    "pop s = (e, a, s')" 
    "invar s'" 
    "α s' = (α s)(e := None)" 
    "(α s) e = Some a" 
    "(y  ran (α s). a  y)"
    using assms
    apply (cases "pop s")
    apply (drule (2) pop_correct)
    apply blast
    done

end

subsubsection "Insert"
text ‹
  If an existing element is inserted, its priority will be overwritten.
  This can be used to implement a decrease-key operation.
›
(* TODO: Implement decrease-key generic algorithm, and specify decrease-key operation here! *)
locale uprio_insert = uprio +
  constrains α :: "'s  ('e  'a::linorder)"
  fixes insert :: "'s  'e  'a  's"
  assumes insert_correct: 
  "invar s  invar (insert s e a)"
  "invar s  α (insert s e a) = (α s)(e  a)" 

subsubsection "Distinct Insert"
text ‹
  This operation only allows insertion of elements
  that are not yet in the queue.
›
locale uprio_distinct_insert = uprio +
  constrains α :: "'s  ('e  'a::linorder)"
  fixes insert :: "'s  'e  'a  's"
  assumes distinct_insert_correct: 
  "invar s; e  dom (α s)  invar (insert s e a)"
  "invar s; e  dom (α s)  α (insert s e a) = (α s)(e  a)" 


subsubsection "Looking up Priorities"
locale uprio_prio = uprio +
  constrains α :: "'s  ('e  'a::linorder)"
  fixes prio :: "'s  'e  'a option"
  assumes prio_correct: 
  "invar s  prio s e = (α s) e"


subsection "Record Based Interface"

record ('e, 'a, 's) uprio_ops =
  upr_α :: "'s  ('e  'a)" 
  upr_invar :: "'s  bool"                 
  upr_empty :: "unit  's"
  upr_isEmpty :: "'s  bool"
  upr_insert :: "'s  'e  'a  's"
  upr_pop :: "'s  ('e × 'a × 's)"
  upr_prio :: "'s  'e  'a option"


locale StdUprioDefs =
  fixes ops :: "('e,'a::linorder,'s, 'more) uprio_ops_scheme"
begin
  abbreviation α where "α == upr_α ops"
  abbreviation invar where "invar == upr_invar ops"
  abbreviation empty where "empty == upr_empty ops"
  abbreviation isEmpty where "isEmpty == upr_isEmpty ops"
  abbreviation insert where "insert == upr_insert ops"
  abbreviation pop where "pop == upr_pop ops"
  abbreviation prio where "prio == upr_prio ops"
end

locale StdUprio =  StdUprioDefs ops +
  uprio_finite α invar + 
  uprio_empty α invar empty + 
  uprio_isEmpty α invar isEmpty + 
  uprio_insert α invar insert + 
  uprio_pop α invar pop + 
  uprio_prio α invar prio
  for ops
begin
  lemmas correct = 
    finite_correct 
    empty_correct 
    isEmpty_correct 
    insert_correct 
    prio_correct
end

locale StdUprio_no_invar = StdUprio + uprio_no_invar α invar

end

Theory ICF_Gen_Algo_Chapter

(*<*)
theory ICF_Gen_Algo_Chapter imports Main begin
(*>*)
text_raw ‹\isasection{Generic Algorithms} \label{ch:GA}›
(*<*)
 end
(*>*)

Theory SetIteratorCollectionsGA

(*  Title:       General Algorithms for Iterators
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section ‹General Algorithms for Iterators over Finite Sets›
theory SetIteratorCollectionsGA
imports 
  "../spec/SetSpec" 
  "../spec/MapSpec" 
begin

subsection ‹Iterate add to Set›

definition iterate_add_to_set where
    "iterate_add_to_set s ins (it::('x,'x_set) set_iterator) = 
     it (λ_. True) (λx σ. ins x σ) s"

lemma iterate_add_to_set_correct :
assumes ins_OK: "set_ins α invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "α (iterate_add_to_set s ins it) = S0  α s  invar (iterate_add_to_set s ins it)"
unfolding iterate_add_to_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="λS σ. α σ = S  α s  invar σ"])
apply (insert ins_OK s_OK)
apply (simp_all add: set_ins_def)
done

lemma iterate_add_to_set_dj_correct :
assumes ins_dj_OK: "set_ins_dj α invar ins_dj"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
assumes dj: "S0  α s = {}"
shows "α (iterate_add_to_set s ins_dj it) = S0  α s  invar (iterate_add_to_set s ins_dj it)"
unfolding iterate_add_to_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="λS σ. α σ = S  α s  invar σ"])
apply (insert ins_dj_OK s_OK dj)
apply (simp_all add: set_ins_dj_def set_eq_iff)
done

subsection ‹Iterator to Set›

definition iterate_to_set where
    "iterate_to_set emp ins_dj (it::('x,'x_set) set_iterator) = 
     iterate_add_to_set (emp ()) ins_dj it"

lemma iterate_to_set_alt_def[code] :
    "iterate_to_set emp ins_dj (it::('x,'x_set) set_iterator) = 
     it (λ_. True) (λx σ. ins_dj x σ) (emp ())"
unfolding iterate_to_set_def iterate_add_to_set_def by simp

lemma iterate_to_set_correct :
assumes ins_dj_OK: "set_ins_dj α invar ins_dj"
assumes emp_OK: "set_empty α invar emp"
assumes it: "set_iterator it S0"
shows "α (iterate_to_set emp ins_dj it) = S0  invar (iterate_to_set emp ins_dj it)"
unfolding iterate_to_set_def
using iterate_add_to_set_dj_correct [OF ins_dj_OK _ it, of "emp ()"] emp_OK
by (simp add: set_empty_def)


subsection ‹Iterate image/filter add to Set›

text ‹Iterators only visit element once. Therefore the image operations makes sense for
filters only if an injective function is used. However, when adding to a set using
non-injective functions is fine.›

lemma iterate_image_filter_add_to_set_correct :
assumes ins_OK: "set_ins α invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "α (iterate_add_to_set s ins (set_iterator_image_filter f it)) = 
          {b . a. a  S0  f a = Some b}  α s  
       invar (iterate_add_to_set s ins  (set_iterator_image_filter f it))"
unfolding iterate_add_to_set_def set_iterator_image_filter_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="λS σ. α σ = {b . a. a  S  f a = Some b}  α s  invar σ"])
apply (insert ins_OK s_OK)
apply (simp_all add: set_ins_def split: option.split)
apply auto
done


lemma iterate_image_filter_to_set_correct :
assumes ins_OK: "set_ins α invar ins"
assumes emp_OK: "set_empty α invar emp"
assumes it: "set_iterator it S0"
shows "α (iterate_to_set emp ins (set_iterator_image_filter f it)) = 
          {b . a. a  S0  f a = Some b}  
       invar (iterate_to_set emp ins  (set_iterator_image_filter f it))"
unfolding iterate_to_set_def 
using iterate_image_filter_add_to_set_correct [OF ins_OK _ it, of "emp ()" f] emp_OK
by (simp add: set_empty_def)

text‹For completeness lets also consider injective versions.›

lemma iterate_inj_image_filter_add_to_set_correct :
assumes ins_dj_OK: "set_ins_dj α invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
assumes dj: "{y. x. x  S0  f x = Some y}  α s = {}"
assumes f_inj_on: "inj_on f (S0  dom f)"
shows "α (iterate_add_to_set s ins (set_iterator_image_filter f it)) = 
          {b . a. a  S0  f a = Some b}  α s  
       invar (iterate_add_to_set s ins  (set_iterator_image_filter f it))"
proof -
  from set_iterator_image_filter_correct [OF it f_inj_on]
  have it_f: "set_iterator (set_iterator_image_filter f it)
        {y. x. x  S0  f x = Some y}" by simp

  from iterate_add_to_set_dj_correct [OF ins_dj_OK, OF s_OK it_f dj]
  show ?thesis by auto
qed


lemma iterate_inj_image_filter_to_set_correct :
assumes ins_OK: "set_ins_dj α invar ins"
assumes emp_OK: "set_empty α invar emp"
assumes it: "set_iterator it S0"
assumes f_inj_on: "inj_on f (S0  dom f)"
shows "α (iterate_to_set emp ins (set_iterator_image_filter f it)) = 
          {b . a. a  S0  f a = Some b}  
       invar (iterate_to_set emp ins  (set_iterator_image_filter f it))"
unfolding iterate_to_set_def 
using iterate_inj_image_filter_add_to_set_correct [OF ins_OK _ it _ f_inj_on, of "emp ()"] emp_OK
by (simp add: set_empty_def)


subsection ‹Iterate diff Set›

definition iterate_diff_set where
    "iterate_diff_set s del (it::('x,'x_set) set_iterator) = 
     it (λ_. True) (λx σ. del x σ) s"

lemma iterate_diff_correct :
assumes del_OK: "set_delete α invar del"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "α (iterate_diff_set s del it) = α s - S0  invar (iterate_diff_set s del it)"
unfolding iterate_diff_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="λS σ. α σ = α s - S  invar σ"])
apply (insert del_OK s_OK)
apply (auto simp add: set_delete_def set_eq_iff)
done

subsection ‹Iterate add to Map›

definition iterate_add_to_map where
    "iterate_add_to_map m update (it::('k × 'v,'kv_map) set_iterator) = 
     it (λ_. True) (λ(k,v) σ. update k v σ) m"

lemma iterate_add_to_map_correct :
assumes upd_OK: "map_update α invar upd"
assumes m_OK: "invar m"
assumes it: "map_iterator it M"
shows "α (iterate_add_to_map m upd it) = α m ++ M   invar (iterate_add_to_map m upd it)"
using assms
unfolding iterate_add_to_map_def
apply (rule_tac map_iterator_no_cond_rule_insert_P [OF it,
         where ?I="λd σ. (α σ = α m ++ M |` d)  invar σ"])
apply (simp_all add: map_update_def restrict_map_insert)
done

lemma iterate_add_to_map_dj_correct :
assumes upd_OK: "map_update_dj α invar upd"
assumes m_OK: "invar m"
assumes it: "map_iterator it M"
assumes dj: "dom M  dom (α m) = {}"
shows "α (iterate_add_to_map m upd it) = α m ++ M   invar (iterate_add_to_map m upd it)"
using assms
unfolding iterate_add_to_map_def
apply (rule_tac map_iterator_no_cond_rule_insert_P [OF it,
         where ?I="λd σ. (α σ = α m ++ M |` d)  invar σ"])
apply (simp_all add: map_update_dj_def restrict_map_insert set_eq_iff)
done


subsection ‹Iterator to Map›

definition iterate_to_map where
    "iterate_to_map emp upd_dj (it::('k × 'v,'kv_map) set_iterator) = 
     iterate_add_to_map (emp ()) upd_dj it"

lemma iterate_to_map_alt_def[code] :
    "iterate_to_map emp upd_dj it = 
     it (λ_. True) (λ(k, v) σ. upd_dj k v σ) (emp ())"
unfolding iterate_to_map_def iterate_add_to_map_def by simp

lemma iterate_to_map_correct :
assumes upd_dj_OK: "map_update_dj α invar upd_dj"
assumes emp_OK: "map_empty α invar emp"
assumes it: "map_iterator it M"
shows "α (iterate_to_map emp upd_dj it) = M  invar (iterate_to_map emp upd_dj it)"
unfolding iterate_to_map_def
using iterate_add_to_map_dj_correct [OF upd_dj_OK _ it, of "emp ()"] emp_OK
by (simp add: map_empty_def)


end


Theory MapGA

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedMap, algorithms for iterators, min, max, to_sorted_list

*)

section ‹\isaheader{Generic Algorithms for Maps}›
theory MapGA
imports SetIteratorCollectionsGA
begin

text_raw ‹\label{thy:MapGA}›

record ('k,'v,'s) map_basic_ops =
  bmap_op_α :: "('k,'v,'s) map_α"
  bmap_op_invar :: "('k,'v,'s) map_invar"
  bmap_op_empty :: "('k,'v,'s) map_empty"
  bmap_op_lookup :: "('k,'v,'s) map_lookup"
  bmap_op_update :: "('k,'v,'s) map_update"
  bmap_op_update_dj :: "('k,'v,'s) map_update_dj"
  bmap_op_delete :: "('k,'v,'s) map_delete"
  bmap_op_list_it :: "('k,'v,'s) map_list_it"
  
record ('k,'v,'s) omap_basic_ops = "('k,'v,'s) map_basic_ops" +
  bmap_op_ordered_list_it :: "'s  ('k,'v,('k×'v) list) map_iterator"
  bmap_op_rev_list_it :: "'s  ('k,'v,('k×'v) list) map_iterator"

locale StdBasicMapDefs = 
  poly_map_iteratei_defs "bmap_op_list_it ops" 
  for ops :: "('k,'v,'s,'more) map_basic_ops_scheme"
begin
  abbreviation α where "α == bmap_op_α ops" 
  abbreviation invar where "invar == bmap_op_invar ops" 
  abbreviation empty where "empty == bmap_op_empty ops" 
  abbreviation lookup where "lookup == bmap_op_lookup ops" 
  abbreviation update where "update == bmap_op_update ops" 
  abbreviation update_dj where "update_dj == bmap_op_update_dj ops" 
  abbreviation delete where "delete == bmap_op_delete ops" 
  abbreviation list_it where "list_it == bmap_op_list_it ops" 
end

locale StdBasicOMapDefs = StdBasicMapDefs ops
  + poly_map_iterateoi_defs "bmap_op_ordered_list_it ops"
  + poly_map_rev_iterateoi_defs "bmap_op_rev_list_it ops"
  for ops :: "('k::linorder,'v,'s,'more) omap_basic_ops_scheme"
begin
  abbreviation ordered_list_it where "ordered_list_it 
     bmap_op_ordered_list_it ops"
  abbreviation rev_list_it where "rev_list_it 
     bmap_op_rev_list_it ops"
end

locale StdBasicMap = StdBasicMapDefs ops +
  map α invar +
  map_empty α invar empty +
  map_lookup α invar lookup  +
  map_update α invar update  +
  map_update_dj α invar update_dj +
  map_delete α invar delete  +
  poly_map_iteratei α invar list_it
  for ops :: "('k,'v,'s,'more) map_basic_ops_scheme"
begin
  lemmas correct[simp] = empty_correct lookup_correct update_correct 
    update_dj_correct delete_correct
end


locale StdBasicOMap = 
  StdBasicOMapDefs ops +
  StdBasicMap ops +
  poly_map_iterateoi α invar ordered_list_it +
  poly_map_rev_iterateoi α invar rev_list_it
  for ops :: "('k::linorder,'v,'s,'more) omap_basic_ops_scheme"
begin
end

context StdBasicMapDefs begin
  definition "g_sng k v  update k v (empty ())"
  definition "g_add m1 m2  iterate m2 (λ(k,v) σ. update k v σ) m1"

  definition 
    "g_sel m P  
      iteratei m (λσ. σ = None) (λx σ. if P x then Some x else None) None"

  definition "g_bex m P  iteratei m (λx. ¬x) (λkv σ. P kv) False"
  definition "g_ball m P  iteratei m id (λkv σ. P kv) True"

  definition "g_size m  iterate m (λ_. Suc) (0::nat)"
  definition "g_size_abort b m  iteratei m (λs. s<b) (λ_. Suc) (0::nat)"

  definition "g_isEmpty m  g_size_abort 1 m = 0"
  definition "g_isSng m  g_size_abort 2 m = 1"

  definition "g_to_list m  iterate m (#) []"

  definition "g_list_to_map l  foldl (λm (k,v). update k v m) (empty ()) 
    (rev l)"

  definition "g_add_dj m1 m2  iterate m2 (λ(k,v) σ. update_dj k v σ) m1"

  definition "g_restrict P m  iterate m 
    (λ(k,v) σ. if P (k,v) then update_dj k v σ else σ) (empty ())"

  definition dflt_ops :: "('k,'v,'s) map_ops" 
    where [icf_rec_def]:
    "dflt_ops  
       
        map_op_α = α,
        map_op_invar = invar,
        map_op_empty = empty,
        map_op_lookup = lookup,
        map_op_update = update,
        map_op_update_dj = update_dj,
        map_op_delete = delete,
        map_op_list_it = list_it,
        map_op_sng = g_sng,
        map_op_restrict = g_restrict, 
        map_op_add = g_add, 
        map_op_add_dj = g_add_dj, 
        map_op_isEmpty = g_isEmpty, 
        map_op_isSng = g_isSng, 
        map_op_ball = g_ball, 
        map_op_bex = g_bex, 
        map_op_size = g_size, 
        map_op_size_abort = g_size_abort, 
        map_op_sel = g_sel, 
        map_op_to_list = g_to_list, 
        map_op_to_map = g_list_to_map
      "

  local_setup Locale_Code.lc_decl_del @{term dflt_ops}

end

lemma update_dj_by_update: 
  assumes "map_update α invar update"
  shows "map_update_dj α invar update"
proof -
  interpret map_update α invar update by fact
  show ?thesis 
    apply (unfold_locales)
    apply (auto simp add: update_correct)
    done
qed

lemma map_iterator_linord_is_it: 
  "map_iterator_linord m it  map_iterator m it"
  unfolding set_iterator_def set_iterator_map_linord_def
  apply (erule set_iterator_genord.set_iterator_weaken_R)
  ..

lemma map_rev_iterator_linord_is_it: 
  "map_iterator_rev_linord m it  map_iterator m it"
  unfolding set_iterator_def set_iterator_map_rev_linord_def
  apply (erule set_iterator_genord.set_iterator_weaken_R)
  ..

context StdBasicMap 
begin
  lemma g_sng_impl: "map_sng α invar g_sng" 
    apply unfold_locales 
    apply (simp_all add: update_correct empty_correct g_sng_def)
    done

  lemma g_add_impl: "map_add α invar g_add"
  proof
    fix m1 m2
    assume "invar m1" "invar m2"

    have A: "g_add m1 m2 = iterate_add_to_map m1 update (iteratei m2)"
      unfolding g_add_def iterate_add_to_map_def by simp
    have (g_add m1 m2) = α m1 ++ α m2  invar (g_add m1 m2)"
      unfolding A
      apply (rule 
        iterate_add_to_map_correct[of α invar update m1 "iteratei m2" m2"])
      apply unfold_locales []
      apply fact
      apply (rule iteratei_correct, fact)
      done
    thus (g_add m1 m2) = α m1 ++ α m2" "invar (g_add m1 m2)" by auto
  qed

  lemma g_sel_impl: "map_sel' α invar g_sel"
  proof -
    have A: "m P. g_sel m P = iterate_sel_no_map (iteratei m) P"
      unfolding g_sel_def iterate_sel_no_map_def iterate_sel_def by simp

    { fix m P
      assume I: "invar m"
      note iterate_sel_no_map_correct[OF iteratei_correct[OF I], of P]
    }
    thus ?thesis
      apply unfold_locales
      unfolding A
      apply (simp add: Bex_def Ball_def image_iff map_to_set_def)
      apply clarify
      apply (metis option.exhaust prod.exhaust)
      apply (simp add: Bex_def Ball_def image_iff map_to_set_def)
      done
  qed
  
  lemma g_bex_impl: "map_bex α invar g_bex"
    apply unfold_locales
    unfolding g_bex_def
    apply (rule_tac I="λit σ. σ  (kvit. P kv)" 
      in iteratei_rule_insert_P)
    by (auto simp: map_to_set_def)

  lemma g_ball_impl: "map_ball α invar g_ball"
    apply unfold_locales
    unfolding g_ball_def
    apply (rule_tac I="λit σ. σ  (kvit. P kv)" 
      in iteratei_rule_insert_P)
    apply (auto simp: map_to_set_def)
    done

  lemma g_size_impl: "map_size α invar g_size"
  proof 
    fix m
    assume I: "invar m"
    have A: "g_size m  iterate_size (iteratei m)"
      unfolding g_size_def iterate_size_def by simp
  
    from iterate_size_correct [OF iteratei_correct[OF I]]
    show "g_size m = card (dom (α m))"
      unfolding A
      by (simp_all add: card_map_to_set) 
  qed 

  lemma g_size_abort_impl: "map_size_abort α invar g_size_abort"
  proof 
    fix s m
    assume I: "invar m"
    have A: "g_size_abort s m  iterate_size_abort (iteratei m) s"
      unfolding g_size_abort_def iterate_size_abort_def by simp
  
    from iterate_size_abort_correct [OF iteratei_correct[OF I]]
    show "g_size_abort s m = min s (card (dom (α m)))"
      unfolding A
      by (simp_all add: card_map_to_set) 
  qed 

  lemma g_isEmpty_impl: "map_isEmpty α invar g_isEmpty"
  proof 
    fix m
    assume I: "invar m"
    interpret map_size_abort α invar g_size_abort by (rule g_size_abort_impl)
    from size_abort_correct[OF I] have 
      "g_size_abort 1 m = min 1 (card (dom (α m)))" .
    thus "g_isEmpty m = (α m = Map.empty)" unfolding g_isEmpty_def
      by (auto simp: min_def card_0_eq[OF finite] I)
  qed

  lemma g_isSng_impl: "map_isSng α invar g_isSng"
  proof 
    fix m
    assume I: "invar m"
    interpret map_size_abort α invar g_size_abort by (rule g_size_abort_impl)
    from size_abort_correct[OF I] have 
      "g_size_abort 2 m = min 2 (card (dom (α m)))" .
    thus "g_isSng m = (k v. α m = [k  v])" unfolding g_isSng_def
      by (auto simp: min_def I card_Suc_eq dom_eq_singleton_conv)
  qed
  
  lemma g_to_list_impl: "map_to_list α invar g_to_list"
  proof 
    fix m 
    assume I: "invar m"

    have A: "g_to_list m = iterate_to_list (iteratei m)"
      unfolding g_to_list_def iterate_to_list_def by simp

    from iterate_to_list_correct [OF iteratei_correct[OF I]]
    have set_l_eq: "set (g_to_list m) = map_to_set (α m)" and 
      dist_l: "distinct (g_to_list m)" unfolding A by simp_all

    from dist_l show dist_fst_l: "distinct (map fst (g_to_list m))"
      by (simp add: distinct_map set_l_eq map_to_set_def inj_on_def)
    
    from map_of_map_to_set[of "(g_to_list m)" m", OF dist_fst_l] set_l_eq
    show "map_of (g_to_list m) = α m" by simp
  qed

  lemma g_list_to_map_impl: "list_to_map α invar g_list_to_map"
  proof -
    {
      fix m0 l
      assume "invar m0"
      hence "invar (foldl (λs (k,v). update k v s) m0 l)  
        α (foldl (λs (k,v). update k v s) m0 l) = α m0 ++ map_of (rev l)"
      proof (induction l arbitrary: m0)
        case Nil thus ?case by simp
      next
        case (Cons kv l)
        obtain k v where [simp]: "kv=(k,v)" by (cases kv) auto
        have "invar (foldl (λs (k, v). update k v s) m0 (kv # l))"
          apply simp
          apply (rule conjunct1[OF Cons.IH])
          apply (simp add: update_correct Cons.prems)
          done
        moreover have (foldl (λs (k, v). update k v s) m0 (kv # l)) =
          α m0 ++ map_of (rev (kv # l))"
          apply simp
          apply (rule trans[OF conjunct2[OF Cons.IH]])
          apply (auto 
            simp: update_correct Cons.prems Map.map_add_def[abs_def]
            split: option.split
          )
          done
        ultimately show ?case
          by simp
      qed
    } thus ?thesis
      apply unfold_locales
      unfolding g_list_to_map_def
      apply (auto simp: empty_correct)
      done
  qed

  lemma g_add_dj_impl: "map_add_dj α invar g_add_dj"
  proof
    fix m1 m2
    assume "invar m1" "invar m2" and DJ: "dom (α m1)  dom (α m2) = {}"

    have A: "g_add_dj m1 m2 = iterate_add_to_map m1 update_dj (iteratei m2)"
      unfolding g_add_dj_def iterate_add_to_map_def by simp
    have (g_add_dj m1 m2) = α m1 ++ α m2  invar (g_add_dj m1 m2)"
      unfolding A
      apply (rule 
        iterate_add_to_map_dj_correct[
        of α invar update_dj m1 "iteratei m2" m2"])
      apply unfold_locales []
      apply fact
      apply (rule iteratei_correct, fact)
      using DJ apply (simp add: Int_ac)
      done
    thus (g_add_dj m1 m2) = α m1 ++ α m2" "invar (g_add_dj m1 m2)" by auto
  qed
  
  lemma g_restrict_impl: "map_restrict α invar α invar g_restrict"
  proof 
    fix m P
    assume I: "invar m"

    have AUX: "k v it σ.
       it  {(k, v). α m k = Some v}; α m k = Some v; (k, v)  it;
        {(k, v). α σ k = Some v} = it  Collect P
        k  dom (α σ)"
    proof (rule ccontr, simp)
      fix k v it σ
      assume "kdom (α σ)" 
      then obtain v' where σ k = Some v'" by auto
      moreover assume "{(k, v). α σ k = Some v} = it  Collect P"
      ultimately have MEM: "(k,v')it" by auto
      moreover assume "it  {(k, v). α m k = Some v}" and m k = Some v"
      ultimately have "v'=v" by auto
      moreover assume "(k,v)it"
      moreover note MEM 
      ultimately show False by simp
    qed

    have (g_restrict P m) = α m |` {k. v. α m k = Some v  P (k, v)} 
      invar (g_restrict P m)"
      unfolding g_restrict_def
      apply (rule_tac I="λit σ. invar σ 
         map_to_set (α σ) = it  Collect P"
        in iterate_rule_insert_P)
      apply (auto simp: I empty_correct update_dj_correct map_to_set_def AUX)
      apply (auto split: if_split_asm)
      apply (rule ext)
      apply (auto simp: Map.restrict_map_def)
      apply force
      apply (rule ccontr)
      apply force
      done
    thus (g_restrict P m) = α m |` {k. v. α m k = Some v  P (k, v)}"
      "invar (g_restrict P m)" by auto
  qed

  lemma dflt_ops_impl: "StdMap dflt_ops"
    apply (rule StdMap_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (rule g_sng_impl g_restrict_impl g_add_impl g_add_dj_impl 
      g_isEmpty_impl g_isSng_impl g_ball_impl g_bex_impl g_size_impl
      g_size_abort_impl g_sel_impl g_to_list_impl g_list_to_map_impl)+
    done
end


context StdBasicOMapDefs 
begin
  definition 
    "g_min m P  
      iterateoi m (λσ. σ = None) (λx σ. if P x then Some x else None) None"

  definition 
    "g_max m P  
      rev_iterateoi m (λσ. σ = None) (λx σ. if P x then Some x else None) None"

  definition "g_to_sorted_list m  rev_iterateo m (#) []"
  definition "g_to_rev_list m  iterateo m (#) []"

  definition dflt_oops :: "('k,'v,'s) omap_ops" 
    where [icf_rec_def]:
    "dflt_oops  map_ops.extend dflt_ops
       
        map_op_ordered_list_it = ordered_list_it,
        map_op_rev_list_it = rev_list_it,
        map_op_min = g_min,
        map_op_max = g_max,
        map_op_to_sorted_list = g_to_sorted_list,
        map_op_to_rev_list = g_to_rev_list
      "
  local_setup Locale_Code.lc_decl_del @{term dflt_oops}

end

context StdBasicOMap 
begin
  lemma g_min_impl: "map_min α invar g_min"
  proof 
    fix m P

    assume I: "invar m"
  
    from iterateoi_correct[OF I]
    have iti': "map_iterator_linord (iterateoi m) (α m)" by simp
    note sel_correct = iterate_sel_no_map_map_linord_correct[OF iti', of P]

    have A: "g_min m P = iterate_sel_no_map (iterateoi m) P"
      unfolding g_min_def iterate_sel_no_map_def iterate_sel_def by simp
  
    { assume "rel_of (α m) P  {}"
      with sel_correct 
      show "g_min m P  Some ` rel_of (α m) P"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { assume "rel_of (α m) P = {}"        
       with sel_correct show "g_min m P = None"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { fix k v
      assume "(k, v)  rel_of (α m) P"
      with sel_correct show "fst (the (g_min m P))  k"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }
  qed

  lemma g_max_impl: "map_max α invar g_max"
  proof 
    fix m P

    assume I: "invar m"
  
    from rev_iterateoi_correct[OF I]
    have iti': "map_iterator_rev_linord (rev_iterateoi m) (α m)" by simp
    note sel_correct = iterate_sel_no_map_map_rev_linord_correct[OF iti', of P]

    have A: "g_max m P = iterate_sel_no_map (rev_iterateoi m) P"
      unfolding g_max_def iterate_sel_no_map_def iterate_sel_def by simp
  
    { assume "rel_of (α m) P  {}"
      with sel_correct 
      show "g_max m P  Some ` rel_of (α m) P"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { assume "rel_of (α m) P = {}"        
       with sel_correct show "g_max m P = None"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { fix k v
      assume "(k, v)  rel_of (α m) P"
      with sel_correct show "fst (the (g_max m P))  k"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }
  qed

  lemma g_to_sorted_list_impl: "map_to_sorted_list α invar g_to_sorted_list"
  proof 
    fix m
    assume I: "invar m"
    note iti = rev_iterateoi_correct[OF I]
    from iterate_to_list_map_rev_linord_correct[OF iti]
    show "sorted (map fst (g_to_sorted_list m))" 
         "distinct (map fst (g_to_sorted_list m))"
         "map_of (g_to_sorted_list m) = α m" 
      unfolding g_to_sorted_list_def iterate_to_list_def by simp_all
  qed

  lemma g_to_rev_list_impl: "map_to_rev_list α invar g_to_rev_list"
  proof 
    fix m
    assume I: "invar m"
    note iti = iterateoi_correct[OF I]
    from iterate_to_list_map_linord_correct[OF iti]
    show "sorted (rev (map fst (g_to_rev_list m)))" 
         "distinct (map fst (g_to_rev_list m))"
         "map_of (g_to_rev_list m) = α m" 
      unfolding g_to_rev_list_def iterate_to_list_def 
      by (simp_all add: rev_map)
  qed
  
  lemma dflt_oops_impl: "StdOMap dflt_oops"
  proof -
    interpret aux: StdMap dflt_ops by (rule dflt_ops_impl)

    show ?thesis
      apply (rule StdOMap_intro)
      apply icf_locales
      apply (simp_all add: icf_rec_unf)
      apply (rule g_min_impl)
      apply (rule g_max_impl)
      apply (rule g_to_sorted_list_impl)
      apply (rule g_to_rev_list_impl)
      done
  qed

end

locale g_image_filter_defs_loc = 
  m1: StdMapDefs ops1 + 
  m2: StdMapDefs ops2
  for ops1 :: "('k1,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k2,'v2,'s2,'m2) map_ops_scheme"
begin
  definition "g_image_filter f m1  m1.iterate m1 (λkv σ. case f kv of 
      None => σ
    | Some (k',v') => m2.update_dj k' v' σ
    ) (m2.empty ())"
end

locale g_image_filter_loc = g_image_filter_defs_loc ops1 ops2 + 
  m1: StdMap ops1 + 
  m2: StdMap ops2
  for ops1 :: "('k1,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k2,'v2,'s2,'m2) map_ops_scheme"
begin
  lemma g_image_filter_impl: 
    "map_image_filter m1.α m1.invar m2.α m2.invar g_image_filter"
  proof 
    fix m k' v' and f :: "('k1 × 'v1)  ('k2 × 'v2) option"
    assume invar_m: "m1.invar m" and
           unique_f: "transforms_to_unique_keys (m1.α m) f"
    
    have A: "g_image_filter f m = 
      iterate_to_map m2.empty m2.update_dj (
        set_iterator_image_filter f (m1.iteratei m))" 
      unfolding g_image_filter_def iterate_to_map_alt_def 
        set_iterator_image_filter_def case_prod_beta
      by simp
  
    from m1.iteratei_correct[OF invar_m] 
    have iti_m: "map_iterator (m1.iteratei m) (m1.α m)" by simp

    from unique_f have inj_on_f: "inj_on f (map_to_set (m1.α m)  dom f)"
      unfolding transforms_to_unique_keys_def inj_on_def Ball_def map_to_set_def
      by auto (metis option.inject)

    define vP where "vP k v  (k' v'. m1.α m k' = Some v'  f (k', v') = Some (k, v))" for k v
    have vP_intro: "k v. (k' v'. m1.α m k' = Some v' 
         f (k', v') = Some (k, v))  vP k v"
      unfolding vP_def by simp
    { fix k v
      have "Eps_Opt (vP k) = Some v  vP k v"
        using unique_f unfolding vP_def transforms_to_unique_keys_def 
        apply (rule_tac Eps_Opt_eq_Some)
        apply (metis prod.inject option.inject)
      done
    } note Eps_vP_elim[simp] = this
    have map_intro: "{y. x. x  map_to_set (m1.α m)  f x = Some y} 
      = map_to_set (λk. Eps_Opt (vP k))"
      by (simp add: map_to_set_def vP_intro set_eq_iff split: prod.splits)

    from set_iterator_image_filter_correct [OF iti_m, OF inj_on_f, 
      unfolded map_intro] 
    have iti_filter: "map_iterator (set_iterator_image_filter f (m1.iteratei m))
          (λk. Eps_Opt (vP k))" by auto

    have upd: "map_update_dj m2.α m2.invar m2.update_dj" by unfold_locales
    have emp: "map_empty m2.α m2.invar m2.empty" by unfold_locales
  
    from iterate_to_map_correct[OF upd emp iti_filter] show
      "map_op_invar ops2 (g_image_filter f m) 
          (map_op_α ops2 (g_image_filter f m) k' = Some v') =
          (k v. map_op_α ops1 m k = Some v  f (k, v) = Some (k', v'))"
      unfolding A vP_def[symmetric]
      by (simp add: vP_intro)
  
  qed
end

sublocale g_image_filter_loc 
  < map_image_filter m1.α m1.invar m2.α m2.invar g_image_filter
  by (rule g_image_filter_impl)


locale g_value_image_filter_defs_loc = 
  m1: StdMapDefs ops1 + 
  m2: StdMapDefs ops2
  for ops1 :: "('k,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k,'v2,'s2,'m2) map_ops_scheme"
begin
  definition "g_value_image_filter f m1  m1.iterate m1 (λ(k,v) σ. 
    case f k v of 
      None => σ
    | Some v' => m2.update_dj k v' σ
    ) (m2.empty ())"
  
end

(* TODO: Move to Misc *)
lemma restrict_map_dom_subset: " dom m  R  m|`R = m"
  apply (rule ext)
  apply (auto simp: restrict_map_def)
  apply (case_tac "m x")
  apply auto
  done


locale g_value_image_filter_loc = g_value_image_filter_defs_loc ops1 ops2 + 
  m1: StdMap ops1 + 
  m2: StdMap ops2
  for ops1 :: "('k,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k,'v2,'s2,'m2) map_ops_scheme"
begin
  lemma g_value_image_filter_impl: 
    "map_value_image_filter m1.α m1.invar m2.α m2.invar g_value_image_filter"
    apply unfold_locales
    unfolding g_value_image_filter_def
    apply (rule_tac I="λit σ. m2.invar σ 
       m2.α σ = (λk. Option.bind (map_op_α ops1 m k) (f k)) |` it"
      in m1.old_iterate_rule_insert_P)

    apply auto []
    apply (auto simp: m2.empty_correct) []
    defer
    apply simp []
    apply (rule restrict_map_dom_subset)
    apply (auto) []
    apply (case_tac "m1.α m x")
    apply (auto) [2]

    apply (auto split: option.split simp: m2.update_dj_correct intro!: ext)
    apply (auto simp: restrict_map_def)
    done
end

sublocale g_value_image_filter_loc 
  < map_value_image_filter m1.α m1.invar m2.α m2.invar g_value_image_filter
  by (rule g_value_image_filter_impl)


end

Theory SetGA

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedSet, algorithms for iterators, min, max, to_sorted_list

*)

section ‹\isaheader{Generic Algorithms for Sets}›
theory SetGA
imports "../spec/SetSpec" SetIteratorCollectionsGA
begin
text_raw ‹\label{thy:SetGA}›

subsection ‹Generic Set Algorithms›

locale g_set_xx_defs_loc = 
  s1: StdSetDefs ops1 + s2: StdSetDefs ops2
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
  definition "g_copy s  s1.iterate s s2.ins_dj (s2.empty ())"
  definition "g_filter P s1  s1.iterate s1 
    (λx σ. if P x then s2.ins_dj x σ else σ) 
    (s2.empty ())"

  definition "g_union s1 s2  s1.iterate s1 s2.ins s2"
  definition "g_diff s1 s2  s2.iterate s2 s1.delete s1"

  definition g_union_list where
    "g_union_list l =
      foldl (λs s'. g_union s' s) (s2.empty ()) l"

  definition "g_union_dj s1 s2  s1.iterate s1 s2.ins_dj s2"

  definition "g_disjoint_witness s1 s2 
    s1.sel s1 (λx. s2.memb x s2)"

  definition "g_disjoint s1 s2 
    s1.ball s1 (λx. ¬s2.memb x s2)"
end

locale g_set_xx_loc = g_set_xx_defs_loc ops1 ops2 +
  s1: StdSet ops1 + s2: StdSet ops2
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
  lemma g_copy_alt: 
    "g_copy s = iterate_to_set s2.empty s2.ins_dj (s1.iteratei s)"
    unfolding iterate_to_set_alt_def g_copy_def ..

  lemma g_copy_impl: "set_copy s1.α s1.invar s2.α s2.invar g_copy" 
  proof -

    have LIS: 
      "set_ins_dj s2.α s2.invar s2.ins_dj" 
      "set_empty s2.α s2.invar s2.empty"
      by unfold_locales

    from iterate_to_set_correct[OF LIS s1.iteratei_correct]
    show ?thesis
      apply unfold_locales
      unfolding g_copy_alt
      by simp_all
  qed

  lemma g_filter_impl: "set_filter s1.α s1.invar s2.α s2.invar g_filter"
  proof
    fix s P
    assume "s1.invar s"
    hence "s2.α (g_filter P s) = {e  s1.α s. P e} 
      s2.invar (g_filter P s)" (is "?G1  ?G2")
      unfolding g_filter_def
      apply (rule_tac I="λit σ. s2.invar σ  s2.α σ = {e  it. P e}" 
        in s1.iterate_rule_insert_P)
      by (auto simp add: s2.empty_correct s2.ins_dj_correct)
    thus ?G1 ?G2 by auto
  qed

  lemma g_union_alt: 
    "g_union s1 s2 = iterate_add_to_set s2 s2.ins (s1.iteratei s1)"
    unfolding iterate_add_to_set_def g_union_def ..

  lemma g_diff_alt:
    "g_diff s1 s2 = iterate_diff_set s1 s1.delete (s2.iteratei s2)"
    unfolding g_diff_def iterate_diff_set_def ..

  lemma g_union_impl:
    "set_union s1.α s1.invar s2.α s2.invar s2.α s2.invar g_union"
  proof -
    have LIS: "set_ins s2.α s2.invar s2.ins" by unfold_locales
    from iterate_add_to_set_correct[OF LIS _ s1.iteratei_correct]
    show ?thesis
      apply unfold_locales
      unfolding g_union_alt
      by simp_all
  qed

  lemma g_diff_impl:
    "set_diff s1.α s1.invar s2.α s2.invar g_diff"
  proof -
    have LIS: "set_delete s1.α s1.invar s1.delete" by unfold_locales
    from iterate_diff_correct[OF LIS _ s2.iteratei_correct]
    show ?thesis
      apply unfold_locales
      unfolding g_diff_alt
      by simp_all
  qed

  lemma g_union_list_impl:
    shows "set_union_list s1.α s1.invar s2.α s2.invar g_union_list"
  proof
    fix l
    note correct = s2.empty_correct set_union.union_correct[OF g_union_impl]

    assume "s1set l. s1.invar s1"
    hence aux: "s. s2.invar s 
           s2.α (foldl (λs s'. g_union s' s) s l) 
           = {s1.α s1 |s1. s1  set l}  s2.α s 
           s2.invar (foldl (λs s'. g_union s' s) s l)"
      by (induct l) (auto simp add: correct)

    from aux [of "s2.empty ()"]
    show "s2.α (g_union_list l) = {s1.α s1 |s1. s1  set l}"
         "s2.invar (g_union_list l)"
      unfolding g_union_list_def
      by (simp_all add: correct)
  qed

  lemma g_union_dj_impl:
    "set_union_dj s1.α s1.invar s2.α s2.invar s2.α s2.invar g_union_dj"
  proof
    fix s1 s2
    assume I: 
      "s1.invar s1" 
      "s2.invar s2"
    assume DJ: "s1.α s1  s2.α s2 = {}"

    have "s2.α (g_union_dj s1 s2) 
      = s1.α s1  s2.α s2
       s2.invar (g_union_dj s1 s2)" (is "?G1  ?G2")
      unfolding g_union_dj_def

      apply (rule_tac I="λit σ. s2.invar σ  s2.α σ = it  s2.α s2" 
        in s1.iterate_rule_insert_P)
      using DJ
      apply (simp_all add: I)
      apply (subgoal_tac "xs2.α σ")
      apply (simp add: s2.ins_dj_correct I)
      apply auto
      done
    thus ?G1 ?G2 by auto
  qed

  lemma g_disjoint_witness_impl: 
    "set_disjoint_witness s1.α s1.invar s2.α s2.invar g_disjoint_witness"
  proof -
    show ?thesis
      apply unfold_locales
      unfolding g_disjoint_witness_def
      by (auto dest: s1.sel'_noneD s1.sel'_someD simp: s2.memb_correct)
  qed

  lemma g_disjoint_impl: 
    "set_disjoint s1.α s1.invar s2.α s2.invar g_disjoint"
  proof -
    show ?thesis
      apply unfold_locales
      unfolding g_disjoint_def
      by (auto simp: s2.memb_correct s1.ball_correct)
  qed
end

sublocale g_set_xx_loc < 
  set_copy s1.α s1.invar s2.α s2.invar g_copy by (rule g_copy_impl)

sublocale g_set_xx_loc < 
  set_filter s1.α s1.invar s2.α s2.invar g_filter by (rule g_filter_impl)

sublocale g_set_xx_loc < 
  set_union s1.α s1.invar s2.α s2.invar s2.α s2.invar g_union 
  by (rule g_union_impl)

sublocale g_set_xx_loc < 
  set_union_dj s1.α s1.invar s2.α s2.invar s2.α s2.invar g_union_dj 
  by (rule g_union_dj_impl)

sublocale g_set_xx_loc < 
  set_diff s1.α s1.invar s2.α s2.invar g_diff 
  by (rule g_diff_impl)

sublocale g_set_xx_loc < 
  set_disjoint_witness s1.α s1.invar s2.α s2.invar g_disjoint_witness
  by (rule g_disjoint_witness_impl)

sublocale g_set_xx_loc < 
  set_disjoint s1.α s1.invar s2.α s2.invar g_disjoint by (rule g_disjoint_impl)




(*sublocale StdBasicSetDefs < g_set_xx: g_set_xx_defs_loc ops ops .
sublocale StdBasicSet < g_set_xx: g_set_xx_loc ops ops
  by unfold_locales
*)

locale g_set_xxx_defs_loc =
  s1: StdSetDefs ops1 +
  s2: StdSetDefs ops2 +
  s3: StdSetDefs ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x,'s3,'more3) set_ops_scheme"
begin
  definition "g_inter s1 s2 
    s1.iterate s1 (λx s. if s2.memb x s2 then s3.ins_dj x s else s) 
      (s3.empty ())"
end

locale g_set_xxx_loc = g_set_xxx_defs_loc ops1 ops2 ops3 +
  s1: StdSet ops1 +
  s2: StdSet ops2 +
  s3: StdSet ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x,'s3,'more3) set_ops_scheme"
begin
  lemma g_inter_impl: "set_inter s1.α s1.invar s2.α s2.invar s3.α s3.invar
    g_inter"
  proof
    fix s1 s2
    assume I: 
      "s1.invar s1" 
      "s2.invar s2"
    have "s3.α (g_inter s1 s2) = s1.α s1  s2.α s2  s3.invar (g_inter s1 s2)"
      unfolding g_inter_def
      apply (rule_tac I="λit σ. s3.α σ = it  s2.α s2  s3.invar σ" 
        in s1.iterate_rule_insert_P) 
      apply (simp_all add: I s3.empty_correct s3.ins_dj_correct s2.memb_correct)
      done
    thus "s3.α (g_inter s1 s2) = s1.α s1  s2.α s2" 
      and "s3.invar (g_inter s1 s2)" by auto
  qed
end    

sublocale g_set_xxx_loc 
  < set_inter s1.α s1.invar s2.α s2.invar s3.α s3.invar g_inter
  by (rule g_inter_impl)


(*sublocale StdBasicSetDefs < g_set_xxx: g_set_xxx_defs_loc ops ops ops .
sublocale StdBasicSet < g_set_xxx: g_set_xxx_loc ops ops ops
  by unfold_locales
*)

locale g_set_xy_defs_loc = 
  s1: StdSet ops1 + s2: StdSet ops2
  for ops1 :: "('x1,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x2,'s2,'more2) set_ops_scheme"
begin
  definition "g_image_filter f s  
    s1.iterate s 
      (λx res. case f x of Some v  s2.ins v res | _  res) 
      (s2.empty ())"

  definition "g_image f s  
    s1.iterate s (λx res. s2.ins (f x) res) (s2.empty ())"

  definition "g_inj_image_filter f s  
    s1.iterate s 
      (λx res. case f x of Some v  s2.ins_dj v res | _  res) 
      (s2.empty ())"

  definition "g_inj_image f s  
    s1.iterate s (λx res. s2.ins_dj (f x) res) (s2.empty ())"

end

locale g_set_xy_loc = g_set_xy_defs_loc ops1 ops2 +
  s1: StdSet ops1 + s2: StdSet ops2
  for ops1 :: "('x1,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x2,'s2,'more2) set_ops_scheme"
begin
  lemma g_image_filter_impl: 
    "set_image_filter s1.α s1.invar s2.α s2.invar g_image_filter"
  proof
    fix f s
    assume I: "s1.invar s"
    have A: "g_image_filter f s == 
         iterate_to_set s2.empty s2.ins 
           (set_iterator_image_filter f (s1.iteratei s))"
      unfolding g_image_filter_def 
        iterate_to_set_alt_def set_iterator_image_filter_def
      by simp
    
    have ins: "set_ins s2.α s2.invar s2.ins"
      and emp: "set_empty s2.α s2.invar s2.empty" by unfold_locales

    from iterate_image_filter_to_set_correct[OF ins emp s1.iteratei_correct]
    show "s2.α (g_image_filter f s) =
          {b. as1.α s. f a = Some b}"
         "s2.invar (g_image_filter f s)"
      unfolding A using I by auto
  qed

  lemma g_image_alt: "g_image f s = g_image_filter (Some o f) s"
    unfolding g_image_def g_image_filter_def
    by auto

  lemma g_image_impl: "set_image s1.α s1.invar s2.α s2.invar g_image" 
  proof -
    interpret set_image_filter s1.α s1.invar s2.α s2.invar g_image_filter 
      by (rule g_image_filter_impl)

    show ?thesis
      apply unfold_locales
      unfolding g_image_alt
      by (auto simp add: image_filter_correct)
  qed

  lemma g_inj_image_filter_impl: 
    "set_inj_image_filter s1.α s1.invar s2.α s2.invar g_inj_image_filter"
  proof
    fix f::"'x1  'x2" and s
    assume I: "s1.invar s" and INJ: "inj_on f (s1.α s  dom f)"
    have A: "g_inj_image_filter f s == 
         iterate_to_set s2.empty s2.ins_dj 
           (set_iterator_image_filter f (s1.iteratei s))"
      unfolding g_inj_image_filter_def 
        iterate_to_set_alt_def set_iterator_image_filter_def
      by simp
    
    have ins_dj: "set_ins_dj s2.α s2.invar s2.ins_dj"
      and emp: "set_empty s2.α s2.invar s2.empty" by unfold_locales


    from set_iterator_image_filter_correct[OF s1.iteratei_correct[OF I] INJ]
    have iti_s1_filter: "set_iterator 
      (set_iterator_image_filter f (s1.iteratei s))
      {y. x. x  s1.α s  f x = Some y}"
      by simp

    from iterate_to_set_correct[OF ins_dj emp, OF iti_s1_filter]
    show "s2.α (g_inj_image_filter f s) =
          {b. as1.α s. f a = Some b}"
         "s2.invar (g_inj_image_filter f s)"
      unfolding A by auto
  qed


  lemma g_inj_image_alt: "g_inj_image f s = g_inj_image_filter (Some o f) s"
    unfolding g_inj_image_def g_inj_image_filter_def
    by auto

  lemma g_inj_image_impl: 
    "set_inj_image s1.α s1.invar s2.α s2.invar g_inj_image" 
  proof -
    interpret set_inj_image_filter 
      s1.α s1.invar s2.α s2.invar g_inj_image_filter 
      by (rule g_inj_image_filter_impl)

    have AUX: "S f. inj_on f S  inj_on (Some  f) (S  dom (Some  f))"
      by (auto intro!: inj_onI dest: inj_onD)
      
    show ?thesis
      apply unfold_locales
      unfolding g_inj_image_alt
      by (auto simp add: inj_image_filter_correct AUX)

  qed

end

sublocale g_set_xy_loc < set_image_filter s1.α s1.invar s2.α s2.invar 
  g_image_filter by (rule g_image_filter_impl)

sublocale g_set_xy_loc < set_image s1.α s1.invar s2.α s2.invar 
  g_image by (rule g_image_impl)

sublocale g_set_xy_loc < set_inj_image s1.α s1.invar s2.α s2.invar 
  g_inj_image by (rule g_inj_image_impl)

locale g_set_xyy_defs_loc = 
  s0: StdSetDefs ops0 + 
  g_set_xx_defs_loc ops1 ops2
  for ops0 :: "('x0,'s0,'more0) set_ops_scheme"
  and ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin
  definition g_Union_image
    :: "('x0  's1)  's0  's2"
    where "g_Union_image f S 
    == s0.iterate S (λx res. g_union (f x) res) (s2.empty ())"
end

locale g_set_xyy_loc = g_set_xyy_defs_loc ops0 ops1 ops2 +
  s0: StdSet ops0 + 
  g_set_xx_loc ops1 ops2
  for ops0 :: "('x0,'s0,'more0) set_ops_scheme"
  and ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('x,'s2,'more2) set_ops_scheme"
begin

  lemma g_Union_image_impl:
    "set_Union_image s0.α s0.invar s1.α s1.invar s2.α s2.invar g_Union_image"
  proof -
    {
      fix s f
      have "s0.invar s; x. x  s0.α s  s1.invar (f x)  
        s2.α (g_Union_image f s) = (s1.α ` f ` s0.α s) 
         s2.invar (g_Union_image f s)"
        apply (unfold g_Union_image_def)
        apply (rule_tac I="λit res. s2.invar res 
           s2.α res = (s1.α`f`(s0.α s - it))" in s0.iterate_rule_P)
        apply (fastforce simp add: s2.empty_correct union_correct)+
        done
    }
    thus ?thesis
      apply unfold_locales
      apply auto
      done
  qed
end

sublocale g_set_xyy_loc < 
  set_Union_image s0.α s0.invar s1.α s1.invar s2.α s2.invar g_Union_image
  by (rule g_Union_image_impl)

subsection ‹Default Set Operations›

record ('x,'s) set_basic_ops = 
  bset_op_α :: "'s  'x set"
  bset_op_invar :: "'s  bool"
  bset_op_empty :: "unit  's"
  bset_op_memb :: "'x  's  bool"
  bset_op_ins :: "'x  's  's"
  bset_op_ins_dj :: "'x  's  's"
  bset_op_delete :: "'x  's  's"
  bset_op_list_it :: "('x,'s) set_list_it"

record ('x,'s) oset_basic_ops = "('x::linorder,'s) set_basic_ops" +
  bset_op_ordered_list_it :: "'s  ('x,'x list) set_iterator"
  bset_op_rev_list_it :: "'s  ('x,'x list) set_iterator"

locale StdBasicSetDefs = 
  poly_set_iteratei_defs "bset_op_list_it ops"
  for ops :: "('x,'s,'more) set_basic_ops_scheme"
begin
  abbreviation α where "α == bset_op_α ops"
  abbreviation invar where "invar == bset_op_invar ops"
  abbreviation empty where "empty == bset_op_empty ops"
  abbreviation memb where "memb == bset_op_memb ops"
  abbreviation ins where "ins == bset_op_ins ops"
  abbreviation ins_dj where "ins_dj == bset_op_ins_dj ops"
  abbreviation delete where "delete == bset_op_delete ops"
  abbreviation list_it where "list_it  bset_op_list_it ops"
end

locale StdBasicOSetDefs = StdBasicSetDefs ops
  + poly_set_iterateoi_defs "bset_op_ordered_list_it ops"
  + poly_set_rev_iterateoi_defs "bset_op_rev_list_it ops"
  for ops :: "('x::linorder,'s,'more) oset_basic_ops_scheme"
begin
  abbreviation "ordered_list_it  bset_op_ordered_list_it ops"
  abbreviation "rev_list_it  bset_op_rev_list_it ops"
end

locale StdBasicSet = StdBasicSetDefs ops +
  set α invar +
  set_empty α invar empty + 
  set_memb α invar memb + 
  set_ins α invar ins + 
  set_ins_dj α invar ins_dj +
  set_delete α invar delete + 
  poly_set_iteratei α invar list_it
  for ops :: "('x,'s,'more) set_basic_ops_scheme"
begin

  lemmas correct[simp] = 
    empty_correct
    memb_correct
    ins_correct
    ins_dj_correct
    delete_correct

end

locale StdBasicOSet =
  StdBasicOSetDefs ops +
  StdBasicSet ops +
  poly_set_iterateoi α invar ordered_list_it +
  poly_set_rev_iterateoi α invar rev_list_it
  for ops :: "('x::linorder,'s,'more) oset_basic_ops_scheme"
begin
end

context StdBasicSetDefs
begin
  definition "g_sng x  ins x (empty ())"
  definition "g_isEmpty s  iteratei s (λc. c) (λ_ _. False) True"
  definition "g_sel' s P  iteratei s ((=) None) 
    (λx _. if P x then Some x else None) None"

  definition "g_ball s P  iteratei s (λc. c) (λx σ. P x) True"
  definition "g_bex s P  iteratei s (λc. ¬c) (λx σ. P x) False"
  definition "g_size s  iteratei s (λ_. True) (λx n . Suc n) 0"
  definition "g_size_abort m s  iteratei s (λσ. σ < m) (λx. Suc) 0"
  definition "g_isSng s  (iteratei s (λσ. σ < 2) (λx. Suc) 0 = 1)"

  definition "g_union s1 s2  iterate s1 ins s2"
  definition "g_diff s1 s2  iterate s2 delete s1"

  definition "g_subset s1 s2  g_ball s1 (λx. memb x s2)"

  definition "g_equal s1 s2  g_subset s1 s2  g_subset s2 s1"

  definition "g_to_list s  iterate s (#) []"

  fun g_from_list_aux where
    "g_from_list_aux accs [] = accs" |
    "g_from_list_aux accs (x#l) = g_from_list_aux (ins x accs) l"
    ― ‹Tail recursive version›

  definition "g_from_list l == g_from_list_aux (empty ()) l"

  definition "g_inter s1 s2 
    iterate s1 (λx s. if memb x s2 then ins_dj x s else s) 
      (empty ())"

  definition "g_union_dj s1 s2  iterate s1 ins_dj s2"
  definition "g_filter P s  iterate s 
    (λx σ. if P x then ins_dj x σ else σ) 
    (empty ())"

  definition "g_disjoint_witness s1 s2  g_sel' s1 (λx. memb x s2)"
  definition "g_disjoint s1 s2  g_ball s1 (λx. ¬memb x s2)"

  definition dflt_ops
    where [icf_rec_def]: "dflt_ops  
      set_op_α = α, 
      set_op_invar = invar, 
      set_op_empty = empty, 
      set_op_memb = memb, 
      set_op_ins = ins, 
      set_op_ins_dj = ins_dj, 
      set_op_delete = delete, 
      set_op_list_it = list_it, 
      set_op_sng = g_sng ,
      set_op_isEmpty = g_isEmpty ,
      set_op_isSng = g_isSng ,
      set_op_ball = g_ball ,
      set_op_bex = g_bex ,
      set_op_size = g_size ,
      set_op_size_abort = g_size_abort ,
      set_op_union = g_union ,
      set_op_union_dj = g_union_dj ,
      set_op_diff = g_diff ,
      set_op_filter = g_filter ,
      set_op_inter = g_inter ,
      set_op_subset = g_subset ,
      set_op_equal = g_equal ,
      set_op_disjoint = g_disjoint ,
      set_op_disjoint_witness = g_disjoint_witness ,
      set_op_sel = g_sel' ,
      set_op_to_list = g_to_list ,
      set_op_from_list = g_from_list
    "

  local_setup Locale_Code.lc_decl_del @{term dflt_ops}
end

context StdBasicSet
begin
  lemma g_sng_impl: "set_sng α invar g_sng"
    apply unfold_locales 
    unfolding g_sng_def
    apply (auto simp: ins_correct empty_correct)
    done

  lemma g_ins_dj_impl: "set_ins_dj α invar ins"
    by unfold_locales (auto simp: ins_correct)

  lemma g_isEmpty_impl: "set_isEmpty α invar g_isEmpty"
  proof 
    fix s assume I: "invar s"
    have A: "g_isEmpty s = iterate_is_empty (iteratei s)"
      unfolding g_isEmpty_def iterate_is_empty_def ..
    from iterate_is_empty_correct[OF iteratei_correct[OF I]]
    show "g_isEmpty s  α s = {}" unfolding A .
  qed

  lemma g_sel'_impl: "set_sel' α invar g_sel'"
  proof -
    have A: "s P. g_sel' s P = iterate_sel_no_map (iteratei s) P"
      unfolding g_sel'_def iterate_sel_no_map_alt_def 
      apply (rule arg_cong[where f="iteratei", THEN cong, THEN cong, THEN cong])
      by auto

    show ?thesis
      unfolding set_sel'_def A
      using iterate_sel_no_map_correct[OF iteratei_correct]
      apply (simp add: Bex_def Ball_def)
      apply (metis option.exhaust)
      done
  qed
   
  lemma g_ball_alt: "g_ball s P = iterate_ball (iteratei s) P"
    unfolding g_ball_def iterate_ball_def by (simp add: id_def)
  lemma g_bex_alt: "g_bex s P = iterate_bex (iteratei s) P"
    unfolding g_bex_def iterate_bex_def ..

  lemma g_ball_impl: "set_ball α invar g_ball"
    apply unfold_locales
    unfolding g_ball_alt
    apply (rule iterate_ball_correct)
    by (rule iteratei_correct)

  lemma g_bex_impl: "set_bex α invar g_bex"
    apply unfold_locales
    unfolding g_bex_alt
    apply (rule iterate_bex_correct)
    by (rule iteratei_correct)

  lemma g_size_alt: "g_size s = iterate_size (iteratei s)"
    unfolding g_size_def iterate_size_def ..
  lemma g_size_abort_alt: "g_size_abort m s = iterate_size_abort (iteratei s) m"
    unfolding g_size_abort_def iterate_size_abort_def ..

  lemma g_size_impl: "set_size α invar g_size"
    apply unfold_locales
    unfolding g_size_alt
    apply (rule conjunct1[OF iterate_size_correct])
    by (rule iteratei_correct)

  lemma g_size_abort_impl: "set_size_abort α invar g_size_abort"
    apply unfold_locales
    unfolding g_size_abort_alt
    apply (rule conjunct1[OF iterate_size_abort_correct])
    by (rule iteratei_correct)

  lemma g_isSng_alt: "g_isSng s = iterate_is_sng (iteratei s)"
    unfolding g_isSng_def iterate_is_sng_def iterate_size_abort_def ..

  lemma g_isSng_impl: "set_isSng α invar g_isSng"
    apply unfold_locales
    unfolding g_isSng_alt
    apply (drule iterate_is_sng_correct[OF iteratei_correct])
    apply (simp add: card_Suc_eq)
    done

  lemma g_union_impl: "set_union α invar α invar α invar g_union"
    unfolding g_union_def[abs_def]
    apply unfold_locales
    apply (rule_tac I="λit σ. invar σ  α σ = it  α s2" 
      in iterate_rule_insert_P, simp_all)+
    done

  lemma g_diff_impl: "set_diff α invar α invar g_diff"
    unfolding g_diff_def[abs_def]
    apply (unfold_locales)
    apply (rule_tac I="λit σ. invar σ  α σ = α s1 - it" 
      in iterate_rule_insert_P, auto)+
    done

  lemma g_subset_impl: "set_subset α invar α invar g_subset"
  proof -
    interpret set_ball α invar g_ball by (rule g_ball_impl)

    show ?thesis 
      apply unfold_locales
      unfolding g_subset_def
      by (auto simp add: ball_correct memb_correct)
  qed

  lemma g_equal_impl: "set_equal α invar α invar g_equal"
  proof -
    interpret set_subset α invar α invar g_subset by (rule g_subset_impl)

    show ?thesis 
      apply unfold_locales
      unfolding g_equal_def
      by (auto simp add: subset_correct)
  qed

  lemma g_to_list_impl: "set_to_list α invar g_to_list"
  proof 
    fix s 
    assume I: "invar s"
    have A: "g_to_list s = iterate_to_list (iteratei s)"
      unfolding g_to_list_def iterate_to_list_def ..
    
    from iterate_to_list_correct [OF iteratei_correct[OF I]]
    show "set (g_to_list s) = α s" and "distinct (g_to_list s)"
      unfolding A
      by auto
  qed

  lemma g_from_list_impl: "list_to_set α invar g_from_list"
  proof -
    { ― ‹Show a generalized lemma›
      fix l accs
      have "invar accs  α (g_from_list_aux accs l) = set l  α accs 
             invar (g_from_list_aux accs l)"
        by (induct l arbitrary: accs)
           (auto simp add: ins_correct)
    } thus ?thesis
      apply (unfold_locales)
      apply (unfold g_from_list_def)
      apply (auto simp add: empty_correct)
      done
  qed

  lemma g_inter_impl: "set_inter α invar α invar α invar g_inter"
    unfolding g_inter_def[abs_def]
    apply unfold_locales
    apply (rule_tac I="λit σ. invar σ  α σ = it  α s2" 
      in iterate_rule_insert_P, auto) []
    apply (rule_tac I="λit σ. invar σ  α σ = it  α s2" 
      in iterate_rule_insert_P, auto)
    done

  lemma g_union_dj_impl: "set_union_dj α invar α invar α invar g_union_dj"
    unfolding g_union_dj_def[abs_def]
    apply unfold_locales
    apply (rule_tac I="λit σ. invar σ  α σ = it  α s2" 
      in iterate_rule_insert_P)
    apply simp
    apply simp
    apply (subgoal_tac "xα σ")
    apply simp
    apply blast
    apply simp
    apply (rule_tac I="λit σ. invar σ  α σ = it  α s2" 
      in iterate_rule_insert_P)
    apply simp
    apply simp
    apply (subgoal_tac "xα σ")
    apply simp
    apply blast
    apply simp
    done

  lemma g_filter_impl: "set_filter α invar α invar g_filter"
    unfolding g_filter_def[abs_def]
    apply (unfold_locales)
    apply (rule_tac I="λit σ. invar σ  α σ = it  Collect P" 
      in iterate_rule_insert_P, auto)
    apply (rule_tac I="λit σ. invar σ  α σ = it  Collect P" 
      in iterate_rule_insert_P, auto)
    done

  lemma g_disjoint_witness_impl: "set_disjoint_witness 
    α invar α invar g_disjoint_witness"
  proof -
    interpret set_sel' α invar g_sel' by (rule g_sel'_impl)
    show ?thesis
      unfolding g_disjoint_witness_def[abs_def]
      apply unfold_locales
      by (auto dest: sel'_noneD sel'_someD simp: memb_correct)
  qed

  lemma g_disjoint_impl: "set_disjoint 
    α invar α invar g_disjoint"
  proof -
    interpret set_ball α invar g_ball by (rule g_ball_impl)
    show ?thesis
      apply unfold_locales
      unfolding g_disjoint_def
      by (auto simp: memb_correct ball_correct)
  qed

end

context StdBasicSet
begin
  lemma dflt_ops_impl: "StdSet dflt_ops"
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (rule g_sng_impl g_isEmpty_impl g_isSng_impl g_ball_impl 
      g_bex_impl g_size_impl g_size_abort_impl g_union_impl g_union_dj_impl
      g_diff_impl g_filter_impl g_inter_impl
      g_subset_impl g_equal_impl g_disjoint_impl
      g_disjoint_witness_impl g_sel'_impl g_to_list_impl
      g_from_list_impl
    )+
    done
end

context StdBasicOSetDefs
begin
  definition "g_min s P  iterateoi s (λx. x = None) 
    (λx _. if P x then Some x else None) None"
  definition "g_max s P  rev_iterateoi s (λx. x = None)
    (λx _. if P x then Some x else None) None"

  definition "g_to_sorted_list s  rev_iterateo s (#) []"
  definition "g_to_rev_list s  iterateo s (#) []"

  definition dflt_oops :: "('x::linorder,'s) oset_ops" 
    where [icf_rec_def]:
    "dflt_oops  set_ops.extend 
      dflt_ops
       
        set_op_ordered_list_it = ordered_list_it,
        set_op_rev_list_it = rev_list_it,
        set_op_min = g_min,
        set_op_max = g_max,
        set_op_to_sorted_list = g_to_sorted_list,
        set_op_to_rev_list = g_to_rev_list
      "
  local_setup Locale_Code.lc_decl_del @{term dflt_oops}

end

context StdBasicOSet
begin
  lemma g_min_impl: "set_min α invar g_min"
  proof 
    fix s P

    assume I: "invar s"
  
    from iterateoi_correct[OF I]
    have iti': "set_iterator_linord (iterateoi s) (α s)" by simp
    note sel_correct = iterate_sel_no_map_linord_correct[OF iti', of P]

    have A: "g_min s P = iterate_sel_no_map (iterateoi s) P"
      unfolding g_min_def iterate_sel_no_map_def iterate_sel_def by simp
  
    { fix x
      assume "xα s" "P x"
      with sel_correct 
      show "g_min s P  Some ` {xα s. P x}" and "the (g_min s P)  x"
        unfolding A by auto
    }

    { assume "{xα s. P x} = {}"        
       with sel_correct show "g_min s P = None"
        unfolding A by auto
    }
  qed

  lemma g_max_impl: "set_max α invar g_max"
  proof 
    fix s P

    assume I: "invar s"
  
    from rev_iterateoi_correct[OF I]
    have iti': "set_iterator_rev_linord (rev_iterateoi s) (α s)" by simp
    note sel_correct = iterate_sel_no_map_rev_linord_correct[OF iti', of P]

    have A: "g_max s P = iterate_sel_no_map (rev_iterateoi s) P"
      unfolding g_max_def iterate_sel_no_map_def iterate_sel_def by simp
  
    { fix x
      assume "xα s" "P x"
      with sel_correct 
      show "g_max s P  Some ` {xα s. P x}" and "the (g_max s P)  x"
        unfolding A by auto
    }

    { assume "{xα s. P x} = {}"        
       with sel_correct show "g_max s P = None"
        unfolding A by auto
    }
  qed

  lemma g_to_sorted_list_impl: "set_to_sorted_list α invar g_to_sorted_list"
  proof 
    fix s
    assume I: "invar s"
    note iti = rev_iterateoi_correct[OF I]
    from iterate_to_list_rev_linord_correct[OF iti]
    show "sorted (g_to_sorted_list s)" 
         "distinct (g_to_sorted_list s)"
         "set (g_to_sorted_list s) = α s" 
      unfolding g_to_sorted_list_def iterate_to_list_def by simp_all
  qed

  lemma g_to_rev_list_impl: "set_to_rev_list α invar g_to_rev_list"
  proof 
    fix s
    assume I: "invar s"
    note iti = iterateoi_correct[OF I]
    from iterate_to_list_linord_correct[OF iti]
    show "sorted (rev (g_to_rev_list s))" 
         "distinct (g_to_rev_list s)"
         "set (g_to_rev_list s) = α s" 
      unfolding g_to_rev_list_def iterate_to_list_def 
      by (simp_all)
  qed

  lemma dflt_oops_impl: "StdOSet dflt_oops"
  proof -
    interpret aux: StdSet dflt_ops by (rule dflt_ops_impl)

    show ?thesis
      apply (rule StdOSet_intro)
      apply icf_locales
      apply (simp_all add: icf_rec_unf)
      apply (rule g_min_impl)
      apply (rule g_max_impl)
      apply (rule g_to_sorted_list_impl)
      apply (rule g_to_rev_list_impl)
      done
  qed

end

subsection "More Generic Set Algorithms"
text ‹
  These algorithms do not have a function specification in a locale, but
  their specification is done  ad-hoc in the correctness lemma.
›

subsubsection "Image and Filter of Cartesian Product"

locale image_filter_cp_defs_loc =
  s1: StdSetDefs ops1 +
  s2: StdSetDefs ops2 +
  s3: StdSetDefs ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  definition "image_filter_cartesian_product f s1 s2 ==
    s1.iterate s1 (λx res.
      s2.iterate s2 (λy res.
        case (f (x, y)) of 
          None  res
        | Some z  (s3.ins z res)
      ) res
    ) (s3.empty ())"

  lemma image_filter_cartesian_product_alt:
    "image_filter_cartesian_product f s1 s2 ==
     iterate_to_set s3.empty s3.ins (set_iterator_image_filter f (
       set_iterator_product (s1.iteratei s1) (λ_. s2.iteratei s2)))"
    unfolding image_filter_cartesian_product_def iterate_to_set_alt_def
      set_iterator_image_filter_def set_iterator_product_def 
    by simp

  definition image_filter_cp where
    "image_filter_cp f P s1 s2 
     image_filter_cartesian_product 
      (λxy. if P xy then Some (f xy) else None) s1 s2"

end

locale image_filter_cp_loc = image_filter_cp_defs_loc ops1 ops2 ops3 +
  s1: StdSet ops1 +
  s2: StdSet ops2 +
  s3: StdSet ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  lemma image_filter_cartesian_product_correct:
    fixes f :: "'x × 'y  'z"
    assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
    shows "s3.α (image_filter_cartesian_product f s1 s2) 
     = { z | x y z. f (x,y) = Some z  xs1.α s1  ys2.α s2 }" (is ?T1)
    "s3.invar (image_filter_cartesian_product f s1 s2)" (is ?T2)
  proof -
    from set_iterator_product_correct 
      [OF s1.iteratei_correct[OF I(1)] s2.iteratei_correct[OF I(2)]]
      have it_s12: "set_iterator 
        (set_iterator_product (s1.iteratei s1) (λ_. s2.iteratei s2))
        (s1.α s1 × s2.α s2)" 
        by simp

      have LIS: 
        "set_ins s3.α s3.invar s3.ins" 
        "set_empty s3.α s3.invar s3.empty"
        by unfold_locales
  
      from iterate_image_filter_to_set_correct[OF LIS it_s12, of f]
      show ?T1 ?T2
        unfolding image_filter_cartesian_product_alt by auto
  qed

  lemma image_filter_cp_correct:
    assumes I: "s1.invar s1" "s2.invar s2"
    shows 
    "s3.α (image_filter_cp f P s1 s2) 
     = { f (x, y) | x y. P (x, y)  xs1.α s1  ys2.α s2 }" (is ?T1)
    "s3.invar (image_filter_cp f P s1 s2)" (is ?T2)
  proof -
    from image_filter_cartesian_product_correct [OF I]
    show "?T1" "?T2"
      unfolding image_filter_cp_def
      by auto
  qed

end

locale inj_image_filter_cp_defs_loc =
  s1: StdSetDefs ops1 +
  s2: StdSetDefs ops2 +
  s3: StdSetDefs ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  definition "inj_image_filter_cartesian_product f s1 s2 ==
    s1.iterate s1 (λx res.
      s2.iterate s2 (λy res.
        case (f (x, y)) of 
          None  res
        | Some z  (s3.ins_dj z res)
      ) res
    ) (s3.empty ())"

  lemma inj_image_filter_cartesian_product_alt:
    "inj_image_filter_cartesian_product f s1 s2 ==
     iterate_to_set s3.empty s3.ins_dj (set_iterator_image_filter f (
       set_iterator_product (s1.iteratei s1) (λ_. s2.iteratei s2)))"
    unfolding inj_image_filter_cartesian_product_def iterate_to_set_alt_def
      set_iterator_image_filter_def set_iterator_product_def 
    by simp

  definition inj_image_filter_cp where
    "inj_image_filter_cp f P s1 s2 
     inj_image_filter_cartesian_product 
      (λxy. if P xy then Some (f xy) else None) s1 s2"

end

locale inj_image_filter_cp_loc = inj_image_filter_cp_defs_loc ops1 ops2 ops3 +
  s1: StdSet ops1 +
  s2: StdSet ops2 +
  s3: StdSet ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('z,'s3,'more3) set_ops_scheme"
begin

  lemma inj_image_filter_cartesian_product_correct:
    fixes f :: "'x × 'y  'z"
    assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
    assumes INJ: "inj_on f (s1.α s1 × s2.α s2  dom f)"
    shows "s3.α (inj_image_filter_cartesian_product f s1 s2) 
     = { z | x y z. f (x,y) = Some z  xs1.α s1  ys2.α s2 }" (is ?T1)
    "s3.invar (inj_image_filter_cartesian_product f s1 s2)" (is ?T2)
  proof -
    from set_iterator_product_correct 
      [OF s1.iteratei_correct[OF I(1)] s2.iteratei_correct[OF I(2)]]
      have it_s12: "set_iterator 
        (set_iterator_product (s1.iteratei s1) (λ_. s2.iteratei s2))
        (s1.α s1 × s2.α s2)" 
        by simp

      have LIS: 
        "set_ins_dj s3.α s3.invar s3.ins_dj" 
        "set_empty s3.α s3.invar s3.empty"
        by unfold_locales
  
      from iterate_inj_image_filter_to_set_correct[OF LIS it_s12 INJ]
      show ?T1 ?T2
        unfolding inj_image_filter_cartesian_product_alt by auto
  qed

  lemma inj_image_filter_cp_correct:
    assumes I: "s1.invar s1" "s2.invar s2"
    assumes INJ: "inj_on f {xs1.α s1 × s2.α s2. P x}"
    shows 
    "s3.α (inj_image_filter_cp f P s1 s2) 
     = { f (x, y) | x y. P (x, y)  xs1.α s1  ys2.α s2 }" (is ?T1)
    "s3.invar (inj_image_filter_cp f P s1 s2)" (is ?T2)
  proof -
    let ?f = "λxy. if P xy then Some (f xy) else None"
    from INJ have INJ': "inj_on ?f (s1.α s1 × s2.α s2  dom ?f)"
      by (force intro!: inj_onI dest: inj_onD split: if_split_asm)

    from inj_image_filter_cartesian_product_correct [OF I INJ']
    show "?T1" "?T2"
      unfolding inj_image_filter_cp_def
      by auto
  qed

end


subsubsection "Cartesian Product"

locale cart_defs_loc = inj_image_filter_cp_defs_loc ops1 ops2 ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x×'y,'s3,'more3) set_ops_scheme"
begin

  definition "cart s1 s2 
    s1.iterate s1 
      (λx. s2.iterate s2 (λy res. s3.ins_dj (x,y) res)) 
      (s3.empty ())"

  lemma cart_alt: "cart s1 s2 == 
    inj_image_filter_cartesian_product Some s1 s2"
    unfolding cart_def inj_image_filter_cartesian_product_def
    by simp

end

locale cart_loc = cart_defs_loc ops1 ops2 ops3 
  + inj_image_filter_cp_loc ops1 ops2 ops3
  for ops1 :: "('x,'s1,'more1) set_ops_scheme"
  and ops2 :: "('y,'s2,'more2) set_ops_scheme"
  and ops3 :: "('x×'y,'s3,'more3) set_ops_scheme"
begin

  lemma cart_correct:
    assumes I[simp, intro!]: "s1.invar s1" "s2.invar s2"
    shows "s3.α (cart s1 s2) 
           = s1.α s1 × s2.α s2" (is ?T1)
    "s3.invar (cart s1 s2)" (is ?T2)
    unfolding cart_alt
    by (auto simp add: 
      inj_image_filter_cartesian_product_correct[OF I, where f=Some])

end


subsection ‹Generic Algorithms outside basic-set›
text ‹
  In this section, we present some generic algorithms that are not
  formulated in terms of basic-set. They are useful for setting up 
  some data structures.
›

subsection ‹Image (by image-filter)›
definition "iflt_image iflt f s == iflt (λx. Some (f x)) s"

lemma iflt_image_correct:
  assumes "set_image_filter α1 invar1 α2 invar2 iflt"
  shows "set_image α1 invar1 α2 invar2 (iflt_image iflt)"
proof -
  interpret set_image_filter α1 invar1 α2 invar2 iflt by fact
  show ?thesis
    apply (unfold_locales)
    apply (unfold iflt_image_def)
    apply (auto simp add: image_filter_correct)
    done
qed

subsection‹Injective Image-Filter (by image-filter)›

definition [code_unfold]: "iflt_inj_image = iflt_image"

lemma iflt_inj_image_correct:
  assumes "set_inj_image_filter α1 invar1 α2 invar2 iflt"
  shows "set_inj_image α1 invar1 α2 invar2 (iflt_inj_image iflt)"
proof -
  interpret set_inj_image_filter α1 invar1 α2 invar2 iflt by fact

  show ?thesis
    apply (unfold_locales)
    apply (unfold iflt_image_def iflt_inj_image_def)
    apply (subst inj_image_filter_correct)
    apply (auto simp add: dom_const intro: inj_onI dest: inj_onD)
    apply (subst inj_image_filter_correct)
    apply (auto simp add: dom_const intro: inj_onI dest: inj_onD)
    done
qed


subsection‹Filter (by image-filter)›
definition "iflt_filter iflt P s == iflt (λx. if P x then Some x else None) s"

lemma iflt_filter_correct:
  fixes α1 :: "'s1  'a set"
  fixes α2 :: "'s2  'a set"
  assumes "set_inj_image_filter α1 invar1 α2 invar2 iflt"
  shows "set_filter α1 invar1 α2 invar2 (iflt_filter iflt)"
proof (rule set_filter.intro)
  fix s P
  assume invar_s: "invar1 s"
  interpret S: set_inj_image_filter α1 invar1 α2 invar2 iflt by fact

  let ?f' = "λx::'a. if P x then Some x else None"
  have inj_f': "inj_on ?f' (α1 s  dom ?f')"
    by (simp add: inj_on_def Ball_def domIff)
  note correct' = S.inj_image_filter_correct [OF invar_s inj_f',
    folded iflt_filter_def]

  show "invar2 (iflt_filter iflt P s)"
       "α2 (iflt_filter iflt P s) = {e  α1 s. P e}"
    by (auto simp add: correct')
qed

end

Theory SetByMap

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedMap, transfer of iterators to OrderedSet

*)
section ‹\isaheader{Implementing Sets by Maps}›
theory SetByMap
imports 
  "../spec/SetSpec"
  "../spec/MapSpec"
  SetGA
  MapGA
begin
text_raw ‹\label{thy:SetByMap}›

text ‹
  In this theory, we show how to implement sets
  by maps.
›

(* TODO: We could also define some more operations directly,
  e.g. union, ball, bex, … *)

text ‹Auxiliary lemma›
lemma foldli_foldli_map_eq:
  "foldli (foldli l (λx. True) (λx l. l@[f x]) []) c f' σ0
    = foldli l c (f' o f) σ0"
proof -
  show ?thesis
    apply (simp add: map_by_foldl foldli_map foldli_foldl)
    done
qed

locale SetByMapDefs =
  map: StdBasicMapDefs ops
  for ops :: "('x,unit,'s,'more) map_basic_ops_scheme"
begin
  definition "α s  dom (map.α s)"
  definition "invar s  map.invar s"
  definition empty where "empty  map.empty"
  definition "memb x s  map.lookup x s  None"
  definition "ins x s  map.update x () s"
  definition "ins_dj x s  map.update_dj x () s"
  definition "delete x s  map.delete x s"
  definition list_it :: "'s  ('x,'x list) set_iterator" 
    where "list_it s c f σ0  it_to_it (map.list_it s) c (f o fst) σ0"

  local_setup Locale_Code.lc_decl_del @{term list_it}

  lemma list_it_alt: "list_it s = map_iterator_dom (map.iteratei s)"
  proof -
    have A: "f. (λ(x,_). f x) = (λx. f (fst x))" by auto
    show ?thesis
      unfolding list_it_def[abs_def] map_iterator_dom_def
        poly_map_iteratei_defs.iteratei_def
        set_iterator_image_def set_iterator_image_filter_def
      by (auto simp: comp_def)
  qed

  lemma list_it_unfold:
    "it_to_it (list_it s) c f σ0 = map.iteratei s c (f o fst) σ0"
    unfolding list_it_def[abs_def] it_to_it_def
    unfolding poly_map_iteratei_defs.iteratei_def it_to_it_def
    by (simp add: foldli_foldli_map_eq comp_def)

  definition [icf_rec_def]: "dflt_basic_ops  
    bset_op_α = α,
    bset_op_invar = invar,
    bset_op_empty = empty,
    bset_op_memb = memb,
    bset_op_ins = ins,
    bset_op_ins_dj = ins_dj,
    bset_op_delete = delete,
    bset_op_list_it = list_it
    "
  local_setup Locale_Code.lc_decl_del @{term dflt_basic_ops}

end

setup (Record_Intf.add_unf_thms_global @{thms 
    SetByMapDefs.list_it_def[abs_def]
  }) 


(*lemmas [code_unfold] = SetByMapDefs.list_it_def[abs_def]*)

locale SetByMap = SetByMapDefs ops +
  map: StdBasicMap ops
  for ops :: "('x,unit,'s,'more) map_basic_ops_scheme"
begin
  lemma empty_impl: "set_empty α invar empty"
    apply unfold_locales
    unfolding α_def invar_def empty_def
    by (auto simp: map.empty_correct)

  lemma memb_impl: "set_memb α invar memb"
    apply unfold_locales
    unfolding α_def invar_def memb_def
    by (auto simp: map.lookup_correct)

  lemma ins_impl: "set_ins α invar ins"
    apply unfold_locales
    unfolding α_def invar_def ins_def
    by (auto simp: map.update_correct)

  lemma ins_dj_impl: "set_ins_dj α invar ins_dj"
    apply unfold_locales
    unfolding α_def invar_def ins_dj_def
    by (auto simp: map.update_dj_correct)

  lemma delete_impl: "set_delete α invar delete"
    apply unfold_locales
    unfolding α_def invar_def delete_def
    by (auto simp: map.delete_correct)
  
  lemma list_it_impl: "poly_set_iteratei α invar list_it"
  proof
    fix s
    assume I: "invar s"
    hence I': "map.invar s" unfolding invar_def .

    have S: "f. (λ(x,_). f x) = (λxy. f (fst xy))"
      by auto
  
    from map_iterator_dom_correct[OF map.iteratei_correct[OF I']] 
    show "set_iterator (list_it s) (α s)"
      unfolding α_def list_it_alt .

    show "finite (α s)"
      unfolding α_def by (simp add: map.finite[OF I'])
  qed

  lemma dflt_basic_ops_impl: "StdBasicSet dflt_basic_ops"
    apply (rule StdBasicSet.intro)
    apply (simp_all add: icf_rec_unf)
    apply (rule empty_impl memb_impl ins_impl
      ins_dj_impl delete_impl 
      list_it_impl[unfolded SetByMapDefs.list_it_def[abs_def]]
    )+
    done
end


locale OSetByOMapDefs = SetByMapDefs ops +
  map: StdBasicOMapDefs ops
  for ops :: "('x::linorder,unit,'s,'more) omap_basic_ops_scheme"
begin
  definition ordered_list_it :: "'s  ('x,'x list) set_iterator" 
    where "ordered_list_it s c f σ0 
     it_to_it (map.ordered_list_it s) c (f o fst) σ0"
    (*where "list_it s c f σ0 ≡ it_to_it (map.list_it s) c (f o fst) σ0"*)
  local_setup Locale_Code.lc_decl_del @{term ordered_list_it}

  definition rev_list_it :: "'s  ('x,'x list) set_iterator" 
    where "rev_list_it s c f σ0  it_to_it (map.rev_list_it s) c (f o fst) σ0"
    (*where "rev_list_it s c f σ0 ≡ map.rev_iterateoi s c (f o fst) σ0"*)
  local_setup Locale_Code.lc_decl_del @{term rev_list_it}


  definition [icf_rec_def]: "dflt_basic_oops  
    set_basic_ops.extend dflt_basic_ops 
      bset_op_ordered_list_it = ordered_list_it,
      bset_op_rev_list_it = rev_list_it
      "
  local_setup Locale_Code.lc_decl_del @{term dflt_basic_oops}

end

setup (Record_Intf.add_unf_thms_global @{thms 
    OSetByOMapDefs.ordered_list_it_def[abs_def]
    OSetByOMapDefs.rev_list_it_def[abs_def]
  }) 

(*lemmas [code_unfold] = OSetByOMapDefs.ordered_list_it_def[abs_def]
  OSetByOMapDefs.rev_list_it_def[abs_def]*)

locale OSetByOMap = OSetByOMapDefs ops +
  SetByMap ops + map: StdBasicOMap ops
  for ops :: "('x::linorder,unit,'s,'more) omap_basic_ops_scheme"
begin
  lemma ordered_list_it_impl: "poly_set_iterateoi α invar ordered_list_it"
  proof
    fix s
    assume I: "invar s"
    hence I': "map.invar s" unfolding invar_def .

    have S: "f. (λ(x,_). f x) = (λxy. f (fst xy))"
      by auto

    have A: "s. ordered_list_it s = map_iterator_dom (map.iterateoi s)"
      unfolding ordered_list_it_def[abs_def] 
        map_iterator_dom_def set_iterator_image_alt_def map.iterateoi_def 
      by (simp add: S comp_def)
  
    from map_iterator_linord_dom_correct[OF map.iterateoi_correct[OF I']] 
    show "set_iterator_linord (ordered_list_it s) (α s)"
      unfolding α_def A .

    show "finite (α s)"
      unfolding α_def by (simp add: map.finite[OF I'])
  qed

  lemma rev_list_it_impl: "poly_set_rev_iterateoi α invar rev_list_it"
  proof
    fix s
    assume I: "invar s"
    hence I': "map.invar s" unfolding invar_def .

    have S: "f. (λ(x,_). f x) = (λxy. f (fst xy))"
      by auto

    have A: "s. rev_list_it s = map_iterator_dom (map.rev_iterateoi s)"
      unfolding rev_list_it_def[abs_def] 
        map_iterator_dom_def set_iterator_image_alt_def map.rev_iterateoi_def 
      by (simp add: S comp_def)
  
    from map_iterator_rev_linord_dom_correct[
      OF map.rev_iterateoi_correct[OF I']] 
    show "set_iterator_rev_linord (rev_list_it s) (α s)"
      unfolding α_def A .

    show "finite (α s)"
      unfolding α_def by (simp add: map.finite[OF I'])

  qed

  lemma dflt_basic_oops_impl: "StdBasicOSet dflt_basic_oops"
  proof -
    interpret aux: StdBasicSet dflt_basic_ops by (rule dflt_basic_ops_impl)

    show ?thesis
      apply (rule StdBasicOSet.intro)
      apply (rule StdBasicSet.intro)
      apply icf_locales
      apply (simp_all add: icf_rec_unf)
      apply (rule 
        ordered_list_it_impl[unfolded ordered_list_it_def[abs_def]] 
        rev_list_it_impl[unfolded rev_list_it_def[abs_def]]
      )+
      done
  qed
end

sublocale SetByMap < basic: StdBasicSet "dflt_basic_ops" 
  by (rule dflt_basic_ops_impl)

sublocale OSetByOMap < obasic: StdBasicOSet "dflt_basic_oops" 
  by (rule dflt_basic_oops_impl)

lemma proper_it'_map2set: "proper_it' it it' 
   proper_it' (λs c f. it s c (f o fst)) (λs c f. it' s c (f o fst))"
  unfolding proper_it'_def
  apply clarsimp
  apply (drule_tac x=s in spec)
  apply (erule proper_itE)
  apply (rule proper_itI)
  apply (auto simp add: foldli_map[symmetric] intro!: ext)
  done


end

Theory ListGA

section ‹\isaheader{Generic Algorithms for Sequences}›
theory ListGA
imports "../spec/ListSpec" 
begin

subsection ‹Iterators›

subsubsection ‹iteratei (by get, size)›

locale idx_iteratei_loc = 
  list_size + list_get +
  constrains α :: "'s  'a list"
  assumes [simp]: "s. invar s"
begin

  fun idx_iteratei_aux 
    :: "nat  nat  's  (bool)  ('a   )    "
  where
    "idx_iteratei_aux sz i l c f σ = (
      if i=0  ¬ c σ then σ
      else idx_iteratei_aux sz (i - 1) l c f (f (get l (sz-i)) σ)
    )"

  declare idx_iteratei_aux.simps[simp del]

  lemma idx_iteratei_aux_simps[simp]:
    "i=0  idx_iteratei_aux sz i l c f σ = σ"
    "¬c σ  idx_iteratei_aux sz i l c f σ = σ"
    "i0; c σ  idx_iteratei_aux sz i l c f σ = idx_iteratei_aux sz (i - 1) l c f (f (get l (sz-i)) σ)"
    apply -
    apply (subst idx_iteratei_aux.simps, simp)+
    done

  definition idx_iteratei where 
    "idx_iteratei l c f σ  idx_iteratei_aux (size l) (size l) l c f σ"

  lemma idx_iteratei_correct:
    shows "idx_iteratei s = foldli (α s)" 
  proof -
    {
      fix n l
      assume A: "Suc n  length l"
      hence B: "length l - Suc n < length l" by simp
      from A have [simp]: "Suc (length l - Suc n) = length l - n" by simp
      from Cons_nth_drop_Suc[OF B, simplified] have 
        "drop (length l - Suc n) l = l!(length l - Suc n)#drop (length l - n) l" 
        by simp
    } note drop_aux=this

    {
      fix s c f σ i
      assume "invar s" "isize s"
      hence "idx_iteratei_aux (size s) i s c f σ 
        = foldli (drop (size s - i) (α s)) c f σ"
      proof (induct i arbitrary: σ)
        case 0 with size_correct[of s] show ?case by simp
      next
        case (Suc n)
        note [simp, intro!] = Suc.prems(1)
        show ?case proof (cases "c σ")
          case False thus ?thesis by simp
        next
          case [simp, intro!]: True
          show ?thesis using Suc by (simp add: get_correct size_correct drop_aux)
        qed
      qed
    } note aux=this

    show ?thesis
      unfolding idx_iteratei_def[abs_def]
      by (auto simp add: fun_eq_iff aux[of _ "size s", simplified])
  qed

  lemmas idx_iteratei_unfold[code_unfold] = idx_iteratei_correct[symmetric]

  subsubsection ‹reverse\_iteratei (by get, size)›

  fun idx_reverse_iteratei_aux 
    :: "nat  nat  's  (bool)  ('a   )    "
    where
    "idx_reverse_iteratei_aux sz i l c f σ = (
      if i=0  ¬ c σ then σ
      else idx_reverse_iteratei_aux sz (i - 1) l c f (f (get l (i - 1)) σ)
    )"

  declare idx_reverse_iteratei_aux.simps[simp del]

  lemma idx_reverse_iteratei_aux_simps[simp]:
    "i=0  idx_reverse_iteratei_aux sz i l c f σ = σ"
    "¬c σ  idx_reverse_iteratei_aux sz i l c f σ = σ"
    "i0; c σ  idx_reverse_iteratei_aux sz i l c f σ 
    = idx_reverse_iteratei_aux sz (i - 1) l c f (f (get l (i - 1)) σ)"
    by (subst idx_reverse_iteratei_aux.simps, simp)+

  definition "idx_reverse_iteratei l c f σ 
    == idx_reverse_iteratei_aux (size l) (size l) l c f σ"

  lemma idx_reverse_iteratei_correct:
    shows "idx_reverse_iteratei s = foldri (α s)"
  proof -
    {
      fix s c f σ i
      assume "invar s" "isize s"
      hence "idx_reverse_iteratei_aux (size s) i s c f σ 
        = foldri (take i (α s)) c f σ"
      proof (induct i arbitrary: σ)
        case 0 with size_correct[of s] show ?case by simp
      next
        case (Suc n)
        note [simp, intro!] = Suc.prems(1)
        show ?case proof (cases "c σ")
          case False thus ?thesis by simp
        next
          case [simp, intro!]: True
          show ?thesis using Suc 
            by (simp add: get_correct size_correct take_Suc_conv_app_nth)
        qed
      qed
    } note aux=this

    show ?thesis
      unfolding idx_reverse_iteratei_def[abs_def]
      apply (simp add: fun_eq_iff aux[of _ "size s", simplified])
      apply (simp add: size_correct)
    done
  qed

  lemmas idx_reverse_iteratei_unfold[code_unfold] 
    = idx_reverse_iteratei_correct[symmetric]

end

subsection ‹Size (by iterator)›

locale it_size_loc = poly_list_iteratei +
  constrains α :: "'s  'a list"
begin

  definition it_size :: "'s  nat"
    where "it_size l == iterate l (λx res. Suc res) (0::nat)"

  lemma it_size_impl: shows "list_size α invar it_size"
    apply (unfold_locales)
    apply (unfold it_size_def)
    apply (simp add: iterate_correct foldli_foldl)
    done
end

subsubsection ‹Size (by reverse\_iterator)›

locale rev_it_size_loc = poly_list_rev_iteratei +
  constrains α :: "'s  'a list"
begin

  definition rev_it_size :: "'s  nat"
    where "rev_it_size l == rev_iterate l (λx res. Suc res) (0::nat)"

  lemma rev_it_size_impl:
    shows "list_size α invar rev_it_size"
    apply (unfold_locales)
    apply (unfold rev_it_size_def)
    apply (simp add: rev_iterate_correct foldri_foldr)
    done

end

subsection ‹Get (by iteratori)›
locale it_get_loc = poly_list_iteratei + 
  constrains α :: "'s  'a list"
begin

  definition it_get:: "'s  nat  'a" 
    where "it_get s i  
      the (snd (iteratei s
                (λ(i,x). x=None) 
                (λx (i,_). if i=0 then (0,Some x) else (i - 1,None)) 
                (i,None)))"

  lemma it_get_correct:
    shows "list_get α invar it_get"
  proof 
    fix s i 
    assume "invar s" "i < length (α s)"

    define l where "l = α s"
    from i < length (α s)
    show "it_get s i = α s ! i"
      unfolding it_get_def iteratei_correct l_def[symmetric]
    proof (induct i arbitrary: l)
      case 0
      then obtain x xs where l_eq[simp]: "l = x # xs" by (cases l, auto)
      thus ?case by simp
    next
      case (Suc i)
      note ind_hyp = Suc(1)
      note Suc_i_le = Suc(2)
      from Suc_i_le obtain x xs 
        where l_eq[simp]: "l = x # xs" by (cases l, auto)

      from ind_hyp [of xs] Suc_i_le
      show ?case by simp
    qed
  qed
end

end

Theory SetIndex

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Indices of Sets}›
theory SetIndex
imports 
  "../spec/MapSpec"
  "../spec/SetSpec"
begin
text_raw ‹\label{thy:SetIndex}›

text ‹
  This theory defines an indexing operation that builds an index from a set 
  and an indexing function. 

  Here, index is a map from indices to all values of the set with that index.
›

subsection "Indexing by Function"

definition index :: "('a  'i)  'a set  'i  'a set"
  where "index f s i == { xs . f x = i }"

lemma indexI: " xs; f x = i   xindex f s i" by (unfold index_def) auto
lemma indexD: 
  "xindex f s i  xs"
  "xindex f s i  f x = i"
  by (unfold index_def) auto

lemma index_iff[simp]: "xindex f s i  xs  f x = i" by (simp add: index_def)
 
subsection "Indexing by Map"

definition index_map :: "('a  'i)  'a set  'i  'a set"
  where "index_map f s i == let s=index f s i in if s={} then None else Some s"

definition im_α where "im_α im i == case im i of None  {} | Some s  s"

lemma index_map_correct: "im_α (index_map f s) = index f s"
  apply (rule ext)
  apply (unfold index_def index_map_def im_α_def)
  apply auto
  done

subsection "Indexing by Maps and Sets from the Isabelle Collections Framework"
text ‹
  In this theory, we define the generic algorithm as constants outside any locale,
  but prove the correctness lemmas inside a locale that assumes correctness of all
  prerequisite functions.
  Finally, we export the correctness lemmas from the locale.
›

locale index_loc = 
  m: StdMap m_ops +
  s: StdSet s_ops
  for m_ops :: "('i,'s,'m,'more1) map_ops_scheme"
  and s_ops :: "('x,'s,'more2) set_ops_scheme"
begin
  ― ‹Mapping indices to abstract indices›
  definition ci_α' where
    "ci_α' ci i == case m.α ci i of None  None | Some s  Some (s.α s)"

  definition "ci_α == im_α  ci_α'"

  definition ci_invar where
    "ci_invar ci == m.invar ci  (i s. m.α ci i = Some s  s.invar s)"

  lemma ci_impl_minvar: "ci_invar m  m.invar m" by (unfold ci_invar_def) auto

  definition is_index :: "('x  'i)  'x set  'm  bool"
  where
    "is_index f s idx == ci_invar idx  ci_α' idx = index_map f s"

  lemma is_index_invar: "is_index f s idx  ci_invar idx" 
    by (simp add: is_index_def)

  lemma is_index_correct: "is_index f s idx  ci_α idx = index f s"
    by (simp only: is_index_def index_map_def ci_α_def)
       (simp add: index_map_correct)

  definition lookup :: "'i  'm  's" where
    "lookup i m == case m.lookup i m of None  (s.empty ()) | Some s  s"

  lemma lookup_invar': "ci_invar m  s.invar (lookup i m)"
    apply (unfold ci_invar_def lookup_def)
    apply (auto split: option.split simp add: m.lookup_correct s.empty_correct)
    done

  lemma lookup_correct:
    assumes I[simp, intro!]: "is_index f s idx"
    shows 
      "s.α (lookup i idx) = index f s i"
      "s.invar (lookup i idx)"
  proof goal_cases
    case 2 thus ?case using I by (simp add: is_index_def lookup_invar')
  next
    case 1 
    have [simp, intro!]: "m.invar idx" 
      using ci_impl_minvar[OF is_index_invar[OF I]] 
      by simp
    thus ?case 
    proof (cases "m.lookup i idx")
      case None
      hence [simp]: "m.α idx i = None" by (simp add: m.lookup_correct)
      from is_index_correct[OF I] have "index f s i = ci_α idx i" by simp
      also have " = {}" by (simp add: ci_α_def ci_α'_def im_α_def)
      finally show ?thesis by (simp add: lookup_def None s.empty_correct)
    next
      case (Some si)
      hence [simp]: "m.α idx i = Some si" by (simp add: m.lookup_correct)
      from is_index_correct[OF I] have "index f s i = ci_α idx i" by simp
      also have " = s.α si" by (simp add: ci_α_def ci_α'_def im_α_def)
      finally show ?thesis by (simp add: lookup_def Some s.empty_correct)
    qed
  qed

end

locale build_index_loc = index_loc m_ops s_ops +
  t: StdSet t_ops
  for m_ops :: "('i,'s,'m,'more1) map_ops_scheme"
  and s_ops :: "('x,'s,'more3) set_ops_scheme"
  and t_ops :: "('x,'t,'more2) set_ops_scheme"
begin

  text "Building indices"
  definition idx_build_stepfun :: "('x  'i)  'x  'm  'm" where
    "idx_build_stepfun f x m == 
      let i=f x in
        (case m.lookup i m of
          None  m.update i (s.ins x (s.empty ())) m |
          Some s  m.update i (s.ins x s) m
      )"

  definition idx_build :: "('x  'i)  't  'm" where
    "idx_build f t == t.iterate t (idx_build_stepfun f) (m.empty ())"

  lemma idx_build_correct:
    assumes I: "t.invar t"
    shows "ci_α' (idx_build f t) = index_map f (t.α t)" (is ?T1) and
    [simp]: "ci_invar (idx_build f t)" (is ?T2)
  proof -
    have "t.invar t  
      ci_α' (idx_build f t) = index_map f (t.α t)  ci_invar (idx_build f t)"
      apply (unfold idx_build_def)
      apply (rule_tac 
          I="λit m. ci_α' m = index_map f (t.α t - it)  ci_invar m" 
          in t.iterate_rule_P)
      apply assumption
      apply (simp add: ci_invar_def m.empty_correct)
      apply (rule ext)
      apply (unfold ci_α'_def index_map_def index_def)[1]
      apply (simp add: m.empty_correct)
      defer
      apply simp
      apply (rule conjI)
      defer
      apply (unfold idx_build_stepfun_def)[1]
      apply (auto 
        simp add: ci_invar_def m.update_correct m.lookup_correct 
                  s.empty_correct s.ins_correct Let_def 
        split: option.split) [1]
        
      apply (rule ext)
    proof goal_cases
      case prems: (1 x it m i)
      hence INV[simp, intro!]: "m.invar m" by (simp add: ci_invar_def)
      from prems have 
        INVS[simp, intro]: "!!q s. m.α m q = Some s  s.invar s" 
        by (simp add: ci_invar_def)
      
      show ?case proof (cases "i=f x")
        case [simp]: True
        show ?thesis proof (cases "m.α m (f x)")
          case [simp]: None
          hence "idx_build_stepfun f x m = m.update i (s.ins x (s.empty ())) m"
            apply (unfold idx_build_stepfun_def) 
            apply (simp add: m.update_correct m.lookup_correct s.empty_correct)
            done
          hence "ci_α' (idx_build_stepfun f x m) i = Some {x}"
            by (simp add: m.update_correct 
                          s.ins_correct s.empty_correct ci_α'_def)
          also {
            have "None = ci_α' m (f x)" 
              by (simp add: ci_α'_def)
            also from prems(4) have " = index_map f (t.α t - it) i" by simp
            finally have E: "{xa  t.α t - it. f xa = i} = {}" 
              by (simp add: index_map_def index_def split: if_split_asm)
            moreover have 
              "{xa  t.α t - (it - {x}). f xa = i} 
               = {xa  t.α t - it. f xa = i}  {x}"
              using prems(2,3) by auto
            ultimately have "Some {x} = index_map f (t.α t - (it - {x})) i"
              by (unfold index_map_def index_def) auto
          } finally show ?thesis .
        next
          case [simp]: (Some ss)
          hence [simp, intro!]: "s.invar ss" by (simp del: Some)
          hence "idx_build_stepfun f x m = m.update (f x) (s.ins x ss) m"
            by (unfold idx_build_stepfun_def) 
               (simp add: m.update_correct m.lookup_correct)
          hence "ci_α' (idx_build_stepfun f x m) i = Some (insert x (s.α ss))"
            by (simp add: m.update_correct s.ins_correct ci_α'_def)
          also {
              have "Some (s.α ss) = ci_α' m (f x)" 
                by (simp add: ci_α'_def)
            also from prems(4) have " = index_map f (t.α t - it) i" by simp
            finally have E: "{xa  t.α t - it. f xa = i} = s.α ss" 
              by (simp add: index_map_def index_def split: if_split_asm)
            moreover have 
              "{xa  t.α t - (it - {x}). f xa = i} 
               = {xa  t.α t - it. f xa = i}  {x}"
              using prems(2,3) by auto
            ultimately have 
              "Some (insert x (s.α ss)) = index_map f (t.α t - (it - {x})) i"
              by (unfold index_map_def index_def) auto
          }
          finally show ?thesis .
        qed
      next
        case False hence C: "if x" "f xi" by simp_all
        have "ci_α' (idx_build_stepfun f x m) i = ci_α' m i"
          apply (unfold ci_α'_def idx_build_stepfun_def)
          apply (simp 
            split: option.split_asm option.split 
            add: Let_def m.lookup_correct m.update_correct 
                 s.ins_correct s.empty_correct C)
          done
        also from prems(4) have "ci_α' m i = index_map f (t.α t - it) i" 
          by simp
        also have 
          "{xa  t.α t - (it - {x}). f xa = i} = {xa  t.α t - it. f xa = i}"
          using prems(2,3) C by auto
        hence "index_map f (t.α t - it) i = index_map f (t.α t - (it-{x})) i"
          by (unfold index_map_def index_def) simp
        finally show ?thesis .
      qed
    qed
    with I show ?T1 ?T2 by auto
  qed

  lemma idx_build_is_index: 
    "t.invar t  is_index f (t.α t) (idx_build f t)"
    by (simp add: idx_build_correct index_map_correct ci_α_def is_index_def)

end

end

Theory Algos

(*  Title:       Isabelle Collections Framework
    Author:      Peter Lammich <lammich at in.tum.de>
    Maintainer:  Peter Lammich <lammich at in.tum.de>
*)
section ‹\isaheader{More Generic Algorithms}›
theory Algos
imports 
  "../spec/SetSpec"
  "../spec/MapSpec"
  "../spec/ListSpec"
begin
text_raw ‹\label{thy:Algos}›
     

subsection "Injective Map to Naturals"

text "Whether a set is an initial segment of the natural numbers"
definition inatseg :: "nat set  bool" 
  where "inatseg s == k. s = {i::nat. i<k}"

lemma inatseg_simps[simp]:
  "inatseg {}"
  "inatseg {0}"
  by (unfold inatseg_def)
    auto

text "Compute an injective map from objects into an initial 
    segment of the natural numbers"
locale map_to_nat_loc = 
  s: StdSet s_ops +
  m: StdMap m_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and m_ops :: "('x,nat,'m,'more2) map_ops_scheme"
begin

  definition map_to_nat 
    :: "'s  'm" where
    "map_to_nat s ==
      snd (s.iterate s (λx (c,m). (c+1,m.update x c m)) (0,m.empty ()))"

  lemma map_to_nat_correct:
    assumes INV[simp]: "s.invar s"
    shows 
      ― ‹All elements have got a number›
      "dom (m.α (map_to_nat s)) = s.α s" (is ?T1) and
      ― ‹No two elements got the same number›
      [rule_format]: "inj_on (m.α (map_to_nat s)) (s.α s)" (is ?T2) and
      ― ‹Numbering is inatseg›
      [rule_format]: "inatseg (ran (m.α (map_to_nat s)))" (is ?T3) and
      ― ‹The result satisfies the map invariant›
      "m.invar (map_to_nat s)" (is ?T4)
    proof -
      have i_aux: "!!m S S' k v. inj_on m S; S' = insert k S; vran m 
                                  inj_on (m(kv)) S'"
        apply (rule inj_onI)
        apply (simp split: if_split_asm)
        apply (simp add: ran_def)
        apply (simp add: ran_def)
        apply blast
        apply (blast dest: inj_onD)
        done

      have "?T1  ?T2  ?T3  ?T4"
        apply (unfold map_to_nat_def)
        apply (rule_tac I="λit (c,m). 
          m.invar m  
          dom (m.α m) = s.α s - it  
          inj_on (m.α m) (s.α s - it)  
          (ran (m.α m) = {i. i<c})
          " in s.iterate_rule_P)
        apply simp
        apply (simp add: m.empty_correct)
        apply (case_tac σ)
        apply (simp add: m.empty_correct m.update_correct)
        apply (intro conjI)
        apply blast
        apply clarify
        apply (rule_tac m2="m.α ba" and 
                        k2=x and v2=aa and 
                        S'2="(s.α s - (it - {x}))" and 
                        S2="(s.α s - it)" 
                        in i_aux)
        apply auto [3]
        apply auto [1]
        apply (case_tac σ)
        apply (auto simp add: inatseg_def)
        done
      thus ?T1 ?T2 ?T3 ?T4 by auto
    qed
  
end

subsection "Map from Set"
text "Build a map using a set of keys and a function to compute the values."

locale it_dom_fun_to_map_loc =
  s: StdSet s_ops
+ m: StdMap m_ops 
  for s_ops :: "('k,'s,'more1) set_ops_scheme"
  and m_ops :: "('k,'v,'m,'more2) map_ops_scheme"
begin

  definition it_dom_fun_to_map ::
    "'s  ('k  'v)  'm"
    where "it_dom_fun_to_map s f == 
           s.iterate s (λk m. m.update_dj k (f k) m) (m.empty ())"

  lemma it_dom_fun_to_map_correct:
    assumes INV: "s.invar s"
    shows "m.α (it_dom_fun_to_map s f) k 
      = (if k  s.α s then Some (f k) else None)" (is ?G1)
    and "m.invar (it_dom_fun_to_map s f)" (is ?G2)
  proof -
    have "m.α (it_dom_fun_to_map s f) k 
      = (if k  s.α s then Some (f k) else None) 
      m.invar (it_dom_fun_to_map s f)"
      unfolding it_dom_fun_to_map_def
      apply (rule s.iterate_rule_P[where 
        I = "λit res. m.invar res 
         (k. m.α res k = (if (k  (s.α s) - it) then Some (f k) else None))"
        ])
        apply (simp add: INV)

        apply (simp add: m.empty_correct)

        apply (subgoal_tac "xdom (m.α σ)")

        apply (auto simp: INV m.empty_correct m.update_dj_correct) []

        apply auto [2]
      done
    thus ?G1 and ?G2
      by auto
  qed

end


locale set_to_list_defs_loc =
  s: StdSetDefs s_ops
+ l: StdListDefs l_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
  definition "g_set_to_listl s  s.iterate s l.appendl (l.empty ())"
  definition "g_set_to_listr s  s.iterate s l.appendr (l.empty ())"
end

locale set_to_list_loc = set_to_list_defs_loc s_ops l_ops
+ s: StdSet s_ops
+ l: StdList l_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
  lemma g_set_to_listl_correct: 
    assumes I: "s.invar s"
    shows "List.set (l.α (g_set_to_listl s)) = s.α s"
    and "l.invar (g_set_to_listl s)"
    and "distinct (l.α (g_set_to_listl s))"
    using I apply -
    unfolding g_set_to_listl_def
    apply (rule_tac I="λit σ. l.invar σ  List.set (l.α σ) = it 
       distinct (l.α σ)" 
      in s.iterate_rule_insert_P, auto simp: l.correct)+
    done

  lemma g_set_to_listr_correct: 
    assumes I: "s.invar s"
    shows "List.set (l.α (g_set_to_listr s)) = s.α s"
    and "l.invar (g_set_to_listr s)"
    and "distinct (l.α (g_set_to_listr s))"
    using I apply -
    unfolding g_set_to_listr_def
    apply (rule_tac I="λit σ. l.invar σ  List.set (l.α σ) = it
       distinct (l.α σ)" 
      in s.iterate_rule_insert_P, auto simp: l.correct)+
    done

end

end

Theory PrioByAnnotatedList

section ‹\isaheader{Implementing Priority Queues by Annotated Lists}›
theory PrioByAnnotatedList
imports 
  "../spec/AnnotatedListSpec"
  "../spec/PrioSpec"
begin

text ‹
  In this theory, we implement priority queues by annotated lists.

  The implementation is realized as a generic adapter from the
  AnnotatedList to the priority queue interface.

  Priority queues are realized as a sequence of pairs of
  elements and associated priority. The monoids operation
  takes the element with minimum priority.

  The element with minimum priority is extracted from the
  sum over all elements.
  Deleting the element with minimum priority is done by
  splitting the sequence at the point where the minimum priority
  of the elements read so far becomes equal to the minimum priority of 
  all elements.
›

subsection "Definitions"
subsubsection "Monoid"
datatype ('e, 'a) Prio = Infty | Prio 'e 'a

fun p_unwrap :: "('e,'a) Prio  ('e × 'a)" where
"p_unwrap (Prio e a) = (e , a)"

fun p_min :: "('e, 'a::linorder) Prio  ('e, 'a) Prio  ('e, 'a) Prio"  where
  "p_min Infty Infty = Infty"|
  "p_min Infty (Prio e a) = Prio e a"|
  "p_min (Prio e a) Infty = Prio e a"|
  "p_min (Prio e1 a) (Prio e2 b) = (if a  b then Prio e1 a else Prio e2 b)"


lemma p_min_re_neut[simp]: "p_min a Infty = a" by (induct a) auto
lemma p_min_le_neut[simp]: "p_min Infty a = a" by (induct a) auto
lemma p_min_asso: "p_min (p_min a b) c = p_min a (p_min b c)"
  apply(induct a b  rule: p_min.induct )
  apply auto 
  apply (induct c)
  apply auto
  apply (induct c)
  apply auto
  done
lemma lp_mono: "class.monoid_add p_min Infty" 
  by unfold_locales (auto simp add: p_min_asso)

instantiation Prio :: (type,linorder) monoid_add
begin
definition zero_def: "0 == Infty" 
definition plus_def: "a+b == p_min a b"
  
instance by 
  intro_classes 
(auto simp add: p_min_asso zero_def plus_def)
end

fun p_less_eq :: "('e, 'a::linorder) Prio  ('e, 'a) Prio  bool" where
  "p_less_eq (Prio e a) (Prio f b) = (a  b)"|
  "p_less_eq  _ Infty = True"|
  "p_less_eq Infty (Prio e a) = False"

fun p_less :: "('e, 'a::linorder) Prio  ('e, 'a) Prio  bool" where
  "p_less (Prio e a) (Prio f b) = (a < b)"|
  "p_less (Prio e a) Infty = True"|
  "p_less Infty _ = False"

lemma p_less_le_not_le : "p_less x y  p_less_eq x y  ¬ (p_less_eq y x)"
  by (induct x y rule: p_less.induct) auto

lemma p_order_refl : "p_less_eq x x"
  by (induct x) auto

lemma p_le_inf : "p_less_eq Infty x  x = Infty"
  by (induct x) auto

lemma p_order_trans : "p_less_eq x y; p_less_eq y z  p_less_eq x z"
  apply (induct y z rule: p_less.induct)
  apply auto
  apply (induct x)
  apply auto
  apply (cases x)
  apply auto
  apply(induct x)
  apply (auto simp add: p_le_inf)
  apply (metis p_le_inf p_less_eq.simps(2))
  done

lemma p_linear2 : "p_less_eq x y  p_less_eq y x"
  apply (induct x y rule: p_less_eq.induct)
  apply auto
  done

instantiation Prio :: (type, linorder) preorder
begin
definition plesseq_def: "less_eq = p_less_eq"
definition pless_def: "less = p_less"

instance 
  apply (intro_classes)
  apply (simp only: p_less_le_not_le pless_def plesseq_def)
  apply (simp only: p_order_refl plesseq_def pless_def)
  apply (simp only: plesseq_def)
  apply (metis p_order_trans)
  done

end


subsubsection "Operations"
definition alprio_α :: "('s  (unit × ('e,'a::linorder) Prio) list) 
   's  ('e × 'a::linorder) multiset"
  where 
  "alprio_α α al == (mset (map p_unwrap (map snd (α al))))"

definition alprio_invar :: "('s  (unit × ('c, 'd::linorder) Prio) list) 
   ('s  bool)  's  bool" 
  where
  "alprio_invar α invar al == invar al  ( xset (α al). snd xInfty)"

definition alprio_empty  where 
  "alprio_empty empt = empt"

definition alprio_isEmpty  where 
  "alprio_isEmpty isEmpty = isEmpty"

definition alprio_insert :: "(unit  ('e,'a) Prio  's  's) 
   'e  'a::linorder  's   's"  
  where
  "alprio_insert consl e a s = consl () (Prio e a) s"

definition alprio_find :: "('s  ('e,'a::linorder) Prio)  's  ('e × 'a)" 
where
"alprio_find annot s = p_unwrap (annot s)"

definition alprio_delete :: "((('e,'a::linorder) Prio  bool) 
   ('e,'a) Prio  's  ('s × (unit × ('e,'a) Prio) × 's)) 
                       ('s  ('e,'a) Prio)  ('s  's  's)  's  's" 
  where
  "alprio_delete splits annot app s = (let (l, _ , r) 
    = splits (λ x. x(annot s)) Infty s in app l r) "

definition alprio_meld where
  "alprio_meld app = app"

lemmas alprio_defs =
  alprio_invar_def
  alprio_α_def
  alprio_empty_def
  alprio_isEmpty_def
  alprio_insert_def
  alprio_find_def
  alprio_delete_def
  alprio_meld_def

subsection "Correctness"

subsubsection "Auxiliary Lemmas"
lemma sum_list_split: "sum_list (l @ (a::'a::monoid_add) # r) = (sum_list l) + a + (sum_list r)"
  by (induct l) (auto simp add: add.assoc)


lemma p_linear: "(x::('e, 'a::linorder) Prio)  y  y  x"
  by (unfold plesseq_def) (simp only: p_linear2)


lemma p_min_mon: "(x::(('e,'a::linorder) Prio))  y  (z + x)  y"
apply (unfold plus_def plesseq_def)
apply (induct x y rule: p_less_eq.induct)
apply (auto)
apply (induct z)
apply (auto)
done

lemma p_min_mon2: "p_less_eq x y  p_less_eq (p_min z x) y"
apply (induct x y rule: p_less_eq.induct)
apply (auto)
apply (induct z)
apply (auto)
done

lemma ls_min: " x  set (xs:: ('e,'a::linorder) Prio list) . sum_list xs  x"
proof (induct xs)
case Nil thus ?case by auto
next
case (Cons a ins) thus ?case
  apply (auto simp add: plus_def plesseq_def)
  apply (cases a)
  apply auto
  apply (cases "sum_list ins")
  apply auto
  apply (case_tac x)
  apply auto
  apply (cases a)
  apply auto
  apply (cases "sum_list ins")
  apply auto
  done
qed    

lemma infadd: "x  Infty x + y  Infty"
apply (unfold plus_def)
apply (induct x y rule: p_min.induct)
apply auto
done


lemma prio_selects_one: "a+b = a  a+b=(b::('e,'a::linorder) Prio)"
  apply (simp add: plus_def)
  apply (cases "(a,b)" rule: p_min.cases)
  apply simp_all
  done


lemma sum_list_in_set: "(l::('x × ('e,'a::linorder) Prio) list)[]  
  sum_list (map snd l)  set (map snd l)"
  apply (induct l)
  apply simp
  apply (case_tac l)
  apply simp
  using prio_selects_one
  apply auto
  apply force
  apply force
  done

lemma p_unwrap_less_sum: "snd (p_unwrap ((Prio e aa) + b))  aa"
  apply (cases b)
  apply (auto simp add: plus_def)
done

lemma prio_add_alb: "¬ b  (a::('e,'a::linorder)Prio)   b + a = a"
  by (auto simp add: plus_def, cases "(a,b)" rule: p_min.cases) (auto simp add: plesseq_def)

lemma prio_add_alb2: " (a::('e,'a::linorder)Prio)   a + b   a + b = a"
  by (auto simp add: plus_def, cases "(a,b)" rule: p_min.cases) (auto simp add: plesseq_def)

lemma prio_add_abc:
  assumes "(l::('e,'a::linorder)Prio) + a  c" 
  and "¬ l  c"
  shows  "¬ l  a"
proof (rule ccontr)
  assume "¬ ¬ l  a"
  with assms have "l + a = l"
    apply (auto simp add: plus_def plesseq_def)
    apply (cases "(l,a)" rule: p_less_eq.cases)
    apply auto
    done
  with assms show False by simp
qed

lemma prio_add_abc2:
  assumes "(a::('e,'a::linorder)Prio)  a + b" 
  shows "a  b"
proof (rule ccontr)
  assume ann: "¬ a  b"
  hence "a + b = b" 
    apply (auto simp add: plus_def plesseq_def)
    apply (cases "(a,b)" rule: p_min.cases)
    apply auto
    done
  thus False using assms ann by simp
qed


subsubsection "Empty"
lemma alprio_empty_correct: 
  assumes "al_empty α invar empt"
  shows "prio_empty (alprio_α α) (alprio_invar α invar) (alprio_empty empt)"
proof -
  interpret al_empty α invar empt by fact
  show ?thesis
    apply (unfold_locales)
    apply (unfold alprio_invar_def)
    apply auto
    apply (unfold alprio_empty_def)
    apply (auto simp add: empty_correct)
    apply (unfold alprio_α_def)
    apply auto
    apply (simp only: empty_correct)
    done
qed


subsubsection "Is Empty"

lemma alprio_isEmpty_correct: 
  assumes "al_isEmpty α invar isEmpty"
  shows "prio_isEmpty (alprio_α α) (alprio_invar α invar) (alprio_isEmpty isEmpty)"
proof -
  interpret al_isEmpty α invar isEmpty by fact
  show ?thesis by (unfold_locales) (auto simp add: alprio_defs isEmpty_correct)
qed


subsubsection "Insert"
lemma alprio_insert_correct: 
  assumes "al_consl α invar consl"
  shows "prio_insert (alprio_α α) (alprio_invar α invar) (alprio_insert consl)"
proof -
  interpret al_consl α invar consl by fact
  show ?thesis by unfold_locales (auto simp add: alprio_defs consl_correct)
qed


subsubsection "Meld"

lemma alprio_meld_correct: 
  assumes "al_app α invar app"
  shows "prio_meld (alprio_α α) (alprio_invar α invar) (alprio_meld app)"
proof -
  interpret al_app α invar app by fact
  show ?thesis by unfold_locales (auto simp add: alprio_defs app_correct)
qed

subsubsection "Find"

lemma annot_not_inf :
  assumes "(alprio_invar α invar) s" 
  and "(alprio_α α) s  {#}"
  and "al_annot α invar annot"
  shows "annot s  Infty"
proof -
  interpret al_annot α invar annot by fact
  show ?thesis
  proof -
    from assms(1) have invs: "invar s" by (simp add: alprio_defs)
    from assms(2) have sne: "set (α s)  {}"
    proof (cases "set (α s) = {}")
      case True 
      hence "α s = []" by simp
      hence "(alprio_α α) s = {#}" by (simp add: alprio_defs)
      from this assms(2) show ?thesis by simp
    next
      case False thus ?thesis by simp
    qed
    hence "(α s)  []" by simp
    hence " x xs. (α s) = x # xs" by (cases "α s") auto
    from this obtain x xs where [simp]: "(α s) = x # xs" by blast
    from this assms(1) have "snd x  Infty" by (auto simp add: alprio_defs)
    hence "sum_list (map snd (α s))  Infty" by (auto simp add: infadd)
    thus "annot s  Infty" using annot_correct invs by simp
  qed
qed

lemma annot_in_set: 
  assumes "(alprio_invar α invar) s" 
  and "(alprio_α α) s  {#}"
  and "al_annot α invar annot"
  shows "p_unwrap (annot s) ∈# ((alprio_α α) s)"         
proof - 
  interpret al_annot α invar annot by fact
  from assms(2) have snn: "α s  []" by (auto simp add: alprio_defs)
  from assms(1) have invs: "invar s" by (simp add: alprio_defs)
  hence ans: "annot s = sum_list (map snd (α s))" by (simp add: annot_correct)
  let ?P = "map snd (α s)"
  have "annot s  set ?P"
    by (unfold ans) (rule sum_list_in_set[OF snn])
  then show ?thesis
    by (auto intro!: image_eqI simp add: alprio_α_def)
qed

lemma  sum_list_less_elems: "xset xs. snd x  Infty 
   yset_mset (mset (map p_unwrap (map snd xs))).
              snd (p_unwrap (sum_list (map snd xs)))  snd y"          
    proof (induct xs)
    case Nil thus ?case by simp
    next
    case (Cons a as) thus ?case
      apply auto
      apply (cases "(snd a)" rule: p_unwrap.cases)
      apply auto
      apply (cases "sum_list (map snd as)")
      apply auto
      apply (metis linorder_linear p_min_re_neut 
        p_unwrap.simps plus_def [abs_def] snd_eqD)
      apply (auto simp add: p_unwrap_less_sum)
      apply (unfold plus_def)
      apply (cases "(snd a, sum_list (map snd as))" rule: p_min.cases)
      apply auto
      apply (cases "map snd as")
      apply (auto simp add: infadd)
      done
qed  
  
lemma alprio_find_correct: 
  assumes  "al_annot α invar annot"
  shows "prio_find (alprio_α α) (alprio_invar α invar) (alprio_find annot)"
proof -
  interpret al_annot α invar annot by fact
  show ?thesis
    apply unfold_locales
    apply (rule conjI)
    apply (insert assms)
    apply (unfold alprio_find_def)
    apply (simp add:annot_in_set)
    apply (unfold alprio_defs)
    apply (simp add: annot_correct)
    apply (auto simp add: sum_list_less_elems)
    done
qed


subsubsection "Delete"

lemma delpred_mon: 
  "(a:: ('e, 'a::linorder) Prio) b. ((λ x. x  y) a 
     (λ x. x  y) (a + b)) "
proof (intro impI allI) 
  fix a b 
  show "a  y  a + b  y"
    apply (induct a b rule: p_less.induct)
    apply (auto simp add: plus_def)
    apply (metis linorder_linear order_trans 
      p_linear p_min.simps(4) p_min_mon plus_def prio_selects_one)
    apply (metis order_trans p_linear p_min_mon p_min_re_neut plus_def)
    done 
qed

(* alprio_delete erhält die Invariante *)
lemma alpriodel_invar: 
  assumes "alprio_invar α invar s"
  and "al_annot α invar annot"
  and "alprio_α α s  {#}"
  and "al_splits α invar splits"
  and "al_app α invar app"
  shows "alprio_invar α invar (alprio_delete splits annot app s)"
proof -
  interpret al_splits α invar splits by fact
  let ?P = "λx. x  annot s"
  obtain l p r where 
    [simp]:"splits ?P Infty s = (l, p, r)" 
    by (cases "splits ?P Infty s")  auto
  obtain e a where 
    "p = (e, a)" 
    by (cases p, blast)
  hence 
    lear:"splits ?P Infty s = (l, (e,a), r)" 
    by simp
  from annot_not_inf[OF assms(1) assms(3) assms(2)] have 
    "annot s  Infty" .
  hence 
    sv1: "¬ Infty  annot s" 
    by (simp add: plesseq_def, cases "annot s", auto)
  from assms(1) have 
    invs: "invar s" 
    unfolding alprio_invar_def by simp
  interpret al_annot α invar annot by fact
  from invs have 
    sv2: "Infty + sum_list (map snd (α s))  annot s" 
    by (auto simp add: annot_correct plus_def 
      plesseq_def p_min_le_neut p_order_refl)
  note sp = splits_correct[of s "?P" Infty l e a r]
  note dp = delpred_mon[of "annot s"]
  from sp[OF invs dp sv1 sv2 lear] have 
    invlr: "invar l  invar r" and 
    alr: "α s = α l @ (e, a) # α r" 
    by auto
  interpret al_app α invar app by fact
  from invlr app_correct have 
    invapplr: "invar (app l r)" 
    by simp
  from invlr app_correct have 
    sr: "α (app l r) = (α l) @ (α r)" 
    by simp
  from alr have  
    "set (α s)  (set (α l) Un set (α r))" 
    by auto
  with app_correct[of l r] invlr have 
    "set (α s)  set (α (app l r))" by auto
  with invapplr assms(1) 
  show ?thesis 
    unfolding alprio_defs by auto
qed


lemma sum_list_elem:
  assumes " ins = l @ (a::('e,'a::linorder)Prio) # r"  
  and "¬ sum_list l  sum_list ins"  
  and "sum_list l + a  sum_list ins "
  shows " a = sum_list ins"
proof -
  have "¬ sum_list l  a" using assms prio_add_abc by simp
  hence lpa: "sum_list l + a = a" using prio_add_alb by auto
  hence als: "a  sum_list ins" using assms(3) by simp
  have "sum_list ins = a + sum_list r" 
    using lpa sum_list_split[of l a r] assms(1) by auto
  thus ?thesis using prio_add_alb2[of a "sum_list r"] prio_add_abc2 als  
    by auto
qed

lemma alpriodel_right:
  assumes "alprio_invar α invar s"
  and "al_annot α invar annot"
  and "alprio_α α s  {#}"
  and "al_splits α invar splits"
  and "al_app α invar app"
  shows "alprio_α α (alprio_delete splits annot app s) = 
          alprio_α α s - {#p_unwrap (annot s)#}"
proof -
  interpret al_splits α invar splits by fact
  let ?P = "λx. x  annot s"
  obtain l p r where 
    [simp]:"splits ?P Infty s = (l, p, r)" 
    by (cases "splits ?P Infty s")  auto
  obtain e a where 
    "p = (e, a)" 
    by (cases p, blast)
  hence 
    lear:"splits ?P Infty s = (l, (e,a), r)" 
    by simp
  from annot_not_inf[OF assms(1) assms(3) assms(2)] have 
    "annot s  Infty" .
  hence 
    sv1: "¬ Infty  annot s" 
    by (simp add: plesseq_def, cases "annot s", auto)
  from assms(1) have 
    invs: "invar s" 
    unfolding alprio_invar_def by simp
  interpret al_annot α invar annot by fact
  from invs have 
    sv2: "Infty + sum_list (map snd (α s))  annot s" 
    by (auto simp add: annot_correct plus_def 
      plesseq_def p_min_le_neut p_order_refl)
  note sp = splits_correct[of s "?P" Infty l e a r]
  note dp = delpred_mon[of "annot s"]
  
  from sp[OF invs dp sv1 sv2 lear] have 
    invlr: "invar l  invar r" and 
    alr: "α s = α l @ (e, a) # α r" and
    anlel: "¬ sum_list (map snd (α l))  annot s" and 
    aneqa: "(sum_list (map snd (α l)) + a)  annot s"
    by (auto simp add: plus_def zero_def)
  have mapalr: "map snd (α s) = (map snd (α l)) @ a # (map snd (α r))" 
    using alr by simp
  note lsa = sum_list_elem[of "map snd (α s)" "map snd (α l)" a "map snd (α r)"]
  note lsa2 = lsa[OF mapalr]
  hence a_is_annot: "a = annot s" 
    using annot_correct[OF invs] anlel aneqa by auto
  have "map p_unwrap (map snd (α s)) = 
    (map p_unwrap (map snd (α l))) @ (p_unwrap a) 
      # (map p_unwrap (map snd (α r)))" 
    using alr by simp
  hence alpriolst: "(alprio_α α s) = (alprio_α α l) +{# p_unwrap a #}+ (alprio_α α r)" 
    unfolding alprio_defs
    by (simp add: algebra_simps)
  interpret al_app α invar app by fact
  from alpriolst show ?thesis using app_correct[of l r] invlr a_is_annot 
    by (auto simp add: alprio_defs algebra_simps)
qed  

lemma alprio_delete_correct: 
  assumes "al_annot α invar annot"
  and "al_splits α invar splits"
  and "al_app α invar app"
  shows "prio_delete (alprio_α α) (alprio_invar α invar) 
           (alprio_find annot) (alprio_delete splits annot app)"
proof-
  interpret al_annot α invar annot by fact
  interpret al_splits α invar splits by fact
  interpret al_app α invar app by fact
  show ?thesis
    apply intro_locales
    apply (rule alprio_find_correct,simp add: assms) 
    apply unfold_locales
    apply (insert assms)
    apply (simp add: alpriodel_invar)
    apply (simp add: alpriodel_right alprio_find_def)   
    done
qed  

lemmas alprio_correct =
  alprio_empty_correct
  alprio_isEmpty_correct
  alprio_insert_correct
  alprio_delete_correct
  alprio_find_correct
  alprio_meld_correct

locale alprio_defs = StdALDefs ops 
  for ops :: "(unit,('e,'a::linorder) Prio,'s) alist_ops"
begin
  definition [icf_rec_def]: "alprio_ops  
    prio_op_α = alprio_α α,
    prio_op_invar = alprio_invar α invar,
    prio_op_empty = alprio_empty empty,
    prio_op_isEmpty = alprio_isEmpty isEmpty,
    prio_op_insert = alprio_insert consl,
    prio_op_find = alprio_find annot,
    prio_op_delete = alprio_delete splits annot app,
    prio_op_meld = alprio_meld app
    "
  
end

locale alprio = alprio_defs ops + StdAL ops 
  for ops :: "(unit,('e,'a::linorder) Prio,'s) alist_ops"
begin
  lemma alprio_ops_impl: "StdPrio alprio_ops"
    apply (rule StdPrio.intro)
    apply (simp_all add: icf_rec_unf)
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    apply (rule alprio_correct, unfold_locales) []
    done
end
    
end

Theory PrioUniqueByAnnotatedList

section ‹\isaheader{Implementing Unique Priority Queues by Annotated Lists}›
theory PrioUniqueByAnnotatedList
imports 
  "../spec/AnnotatedListSpec"
  "../spec/PrioUniqueSpec"
begin

text ‹
  In this theory we use annotated lists to implement unique priority queues 
  with totally ordered elements.

  This theory is written as a generic adapter from the AnnotatedList interface
  to the unique priority queue interface.

  The annotated list stores a sequence of elements annotated with 
  priorities\footnote{Technically, the annotated list elements are of unit-type,
  and the annotations hold both, the priority queue elements and the priorities.
  This is required as we defined annotated lists to only sum up the elements 
  annotations.}

  The monoids operations forms the maximum over the elements and
  the minimum over the priorities. 
  The sequence of pairs is ordered by ascending elements' order. 
  The insertion point for a new element, or the priority of an existing element
  can be found by splitting the
  sequence at the point where the maximum of the elements read so far gets
  bigger than the element to be inserted.

  The minimum priority can be read out as the sum over the whole sequence.
  Finding the element with minimum priority is done by splitting the sequence
  at the point where the minimum priority of the elements read so far becomes
  equal to the minimum priority of the whole sequence.
›

subsection "Definitions"

subsubsection "Monoid"
datatype ('e, 'a) LP = Infty | LP 'e 'a

fun p_unwrap :: "('e,'a) LP  ('e × 'a)" where
  "p_unwrap (LP e a) = (e , a)"

fun p_min :: "('e::linorder, 'a::linorder) LP  ('e, 'a) LP  ('e, 'a) LP"  where
  "p_min Infty Infty = Infty"|
  "p_min Infty (LP e a) = LP e a"|
  "p_min (LP e a) Infty = LP e a"|
  "p_min (LP e1 a) (LP e2 b) = (LP (max e1 e2) (min a b))"

fun e_less_eq :: "'e  ('e::linorder, 'a::linorder) LP  bool"  where
  "e_less_eq e Infty = False"|
  "e_less_eq e (LP e' _) = (e  e')"


text_raw‹\paragraph{Instantiation of classes}\ \\›
lemma p_min_re_neut[simp]: "p_min a Infty = a" by (induct a) auto
lemma p_min_le_neut[simp]: "p_min Infty a = a" by (induct a) auto
lemma p_min_asso: "p_min (p_min a b) c = p_min a (p_min b c)"
  apply(induct a b  rule: p_min.induct )
  apply (auto)
  apply (induct c)
  apply (auto)
apply (metis max.assoc)
apply (metis min.assoc)
  done

lemma lp_mono: "class.monoid_add p_min Infty" by  unfold_locales  (auto simp add: p_min_asso)

instantiation LP :: (linorder,linorder) monoid_add
begin
definition zero_def: "0 == Infty" 
definition plus_def: "a+b == p_min a b"
  
instance by 
  intro_classes 
(auto simp add: p_min_asso zero_def plus_def)
end

fun p_less_eq :: "('e, 'a::linorder) LP  ('e, 'a) LP  bool" where
  "p_less_eq (LP e a) (LP f b) = (a  b)"|
  "p_less_eq  _ Infty = True"|
  "p_less_eq Infty (LP e a) = False"

fun p_less :: "('e, 'a::linorder) LP  ('e, 'a) LP  bool" where
  "p_less (LP e a) (LP f b) = (a < b)"|
  "p_less (LP e a) Infty = True"|
  "p_less Infty _ = False"

lemma p_less_le_not_le : "p_less x y  p_less_eq x y  ¬ (p_less_eq y x)"
  by (induct x y rule: p_less.induct) auto

lemma p_order_refl : "p_less_eq x x"
  by (induct x) auto

lemma p_le_inf : "p_less_eq Infty x  x = Infty"
  by (induct x) auto

lemma p_order_trans : "p_less_eq x y; p_less_eq y z  p_less_eq x z"
  apply (induct y z rule: p_less.induct)
  apply auto
  apply (induct x)
  apply auto
  apply (cases x)
  apply auto
  apply(induct x)
  apply (auto simp add: p_le_inf)
  apply (metis p_le_inf p_less_eq.simps(2))
  done

lemma p_linear2 : "p_less_eq x y  p_less_eq y x"
  apply (induct x y rule: p_less_eq.induct)
  apply auto
  done

instantiation LP :: (type, linorder) preorder
begin
definition plesseq_def: "less_eq = p_less_eq"
definition pless_def: "less = p_less"

instance 
  apply (intro_classes)
  apply (simp only: p_less_le_not_le pless_def plesseq_def)
  apply (simp only: p_order_refl plesseq_def pless_def)
  apply (simp only: plesseq_def)
  apply (metis p_order_trans)
  done

end

subsubsection "Operations"

definition aluprio_α :: "('s  (unit × ('e::linorder,'a::linorder) LP) list) 
   's  ('e::linorder   'a::linorder)"
  where 
  "aluprio_α α ft == (map_of (map p_unwrap (map snd (α ft))))"

definition aluprio_invar :: "('s  (unit × ('c::linorder, 'd::linorder) LP) list)
   ('s  bool)  's  bool" 
  where
  "aluprio_invar α invar ft == 
     invar ft 
      ( xset (α ft). snd xInfty) 
      sorted (map fst (map p_unwrap (map snd (α ft)))) 
      distinct (map fst (map p_unwrap (map snd (α ft)))) "

definition aluprio_empty  where 
  "aluprio_empty empt = empt"

definition aluprio_isEmpty  where 
  "aluprio_isEmpty isEmpty = isEmpty"

definition aluprio_insert :: 
  "((('e::linorder,'a::linorder) LP  bool) 
   ('e,'a) LP  's  ('s × (unit × ('e,'a) LP) × 's)) 
     ('s  ('e,'a) LP) 
       ('s  bool)
         ('s  's  's) 
           ('s  unit  ('e,'a) LP  's)
             's  'e  'a  's" 
  where
  "
  aluprio_insert splits annot isEmpty app consr s e a = 
    (if e_less_eq e (annot s)  ¬ isEmpty s 
    then
      (let (l, (_,lp) , r) = splits (e_less_eq e) Infty s in 
        (if e < fst (p_unwrap lp)
        then 
          app (consr (consr l () (LP e a))  () lp) r
        else 
          app (consr l () (LP e a)) r  ))
    else 
      consr s () (LP e a))
  "

definition aluprio_pop :: "((('e::linorder,'a::linorder) LP  bool)  ('e,'a) LP
   's  ('s × (unit × ('e,'a) LP) × 's)) 
     ('s  ('e,'a) LP) 
       ('s  's  's) 
         's 
           'e ×'a ×'s" 
  where
  "aluprio_pop splits annot app s = 
    (let (l, (_,lp) , r) = splits (λ x. x  (annot s)) Infty s 
    in 
      (case lp of 
        (LP e a)  
          (e, a, app l r) ))"

definition aluprio_prio :: 
  "((('e::linorder,'a::linorder) LP  bool)  ('e,'a) LP  's 
   ('s × (unit × ('e,'a) LP) × 's)) 
     ('s  ('e,'a) LP) 
       ('s  bool)
         's  'e  'a option" 
  where
  "
  aluprio_prio splits annot isEmpty s e = 
    (if e_less_eq e (annot s)  ¬ isEmpty s 
    then
      (let (l, (_,lp) , r) = splits (e_less_eq e) Infty s in 
        (if e = fst (p_unwrap lp)
        then 
          Some (snd (p_unwrap lp))
        else
          None))
    else 
      None)
  "

lemmas aluprio_defs =
aluprio_invar_def
aluprio_α_def
aluprio_empty_def
aluprio_isEmpty_def
aluprio_insert_def
aluprio_pop_def
aluprio_prio_def

subsection "Correctness"

subsubsection "Auxiliary Lemmas"

lemma p_linear: "(x::('e, 'a::linorder) LP)  y  y  x"
  by (unfold plesseq_def) (simp only: p_linear2)


lemma e_less_eq_mon1: "e_less_eq e x  e_less_eq e (x + y)"
  apply (cases x) 
  apply (auto simp add: plus_def) 
  apply (cases y) 
  apply (auto simp add: max.coboundedI1)
  done
lemma e_less_eq_mon2: "e_less_eq e y  e_less_eq e (x + y)"
  apply (cases x) 
  apply (auto simp add: plus_def) 
  apply (cases y) 
  apply (auto simp add: max.coboundedI2)
  done
lemmas e_less_eq_mon = 
  e_less_eq_mon1
  e_less_eq_mon2

lemma p_less_eq_mon:
  "(x::('e::linorder,'a::linorder) LP)  z  (x + y)  z"
  apply(cases y)
  apply(auto simp add: plus_def)
  apply (cases x)
  apply (cases z)
  apply (auto simp add: plesseq_def)
  apply (cases z)
  apply (auto simp add: min.coboundedI1)
  done

lemma p_less_eq_lem1:
  "¬ (x::('e::linorder,'a::linorder) LP)  z;
  (x + y)  z
   y  z "
  apply (cases x,auto simp add: plus_def)
  apply (cases y, auto)
  apply (cases z, auto simp add: plesseq_def)
  apply (metis min_le_iff_disj)
  done
  
lemma infadd: "x  Infty x + y  Infty"
  apply (unfold plus_def)
  apply (induct x y rule: p_min.induct)
  apply auto
  done


lemma e_less_eq_sum_list: 
  "¬ e_less_eq e (sum_list xs)  x  set xs. ¬ e_less_eq e x"
proof (induct xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  hence "¬ e_less_eq e (sum_list xs)" by (auto simp add: e_less_eq_mon)
  hence v1: "xset xs. ¬ e_less_eq e x" using Cons.hyps by simp
  from Cons.prems have "¬ e_less_eq e a" by (auto simp add: e_less_eq_mon)
  with v1 show "xset (a#xs). ¬ e_less_eq e x" by simp
qed

lemma e_less_eq_p_unwrap: 
  "x  Infty;¬ e_less_eq e x  fst (p_unwrap x) < e"
  by (cases x) auto

lemma e_less_eq_refl :
  "b  Infty  e_less_eq (fst (p_unwrap b)) b"
  by (cases b) auto

lemma e_less_eq_sum_list2:
  assumes 
  "xset (αs). snd x  Infty"
  "((), b)  set (αs)"
  shows "e_less_eq (fst (p_unwrap b)) (sum_list (map snd (αs)))"
  apply(insert assms)
  apply (induct "αs")
  apply (auto simp add: zero_def e_less_eq_mon e_less_eq_refl) 
  done

lemma e_less_eq_lem1:
  "¬ e_less_eq e a;e_less_eq e (a + b)  e_less_eq e b"
  apply (auto simp add: plus_def)
  apply (cases a)
  apply auto
  apply (cases b)
  apply auto
  apply (metis le_max_iff_disj)
  done

lemma p_unwrap_less_sum: "snd (p_unwrap ((LP e aa) + b))  aa"
  apply (cases b)
  apply (auto simp add: plus_def)
done

lemma  sum_list_less_elems: "xset xs. snd x  Infty 
  yset (map snd (map p_unwrap (map snd xs))).
              snd (p_unwrap (sum_list (map snd xs)))  y"          
    proof (induct xs)
    case Nil thus ?case by simp
    next
    case (Cons a as) thus ?case
      apply auto
      apply (cases "(snd a)" rule: p_unwrap.cases)
      apply auto
      apply (cases "sum_list (map snd as)")
      apply auto
      apply (metis linorder_linear p_min_re_neut p_unwrap.simps 
        plus_def[abs_def] snd_eqD)
      apply (auto simp add: p_unwrap_less_sum)
      apply (unfold plus_def)
      apply (cases "(snd a, sum_list (map snd as))" rule: p_min.cases)
      apply auto
      apply (cases "map snd as")
      apply (auto simp add: infadd)
      apply (metis min.coboundedI2 snd_conv)
      done
qed

lemma distinct_sortet_list_app:
  "sorted xs; distinct xs; xs = as @ b # cs
    x set cs. b < x"
  by (metis distinct.simps(2) distinct_append 
    antisym_conv2 sorted.simps(2) sorted_append)

lemma distinct_sorted_list_lem1:
  assumes 
  "sorted xs"
  "sorted ys"
  "distinct xs"
  "distinct ys"
  "  x  set xs. x < e"
  "  y  set ys. e < y"
  shows 
  "sorted (xs @ e # ys)"
  "distinct (xs @ e # ys)"
proof -
  from assms (5,6)
  have "xset xs. yset ys. x  y" by force
  thus "sorted (xs @ e # ys)"
    using assms
    by (auto simp add: sorted_append)
  have "set xs  set ys = {}" using assms (5,6) by force
  thus "distinct (xs @ e # ys)"
    using assms
    by (auto)
qed

lemma distinct_sorted_list_lem2:
  assumes 
  "sorted xs"
  "sorted ys"
  "distinct xs"
  "distinct ys"
  "e < e'"  
  "  x  set xs. x < e"
  "  y  set ys. e' < y"
  shows 
  "sorted (xs @ e # e' # ys)"
  "distinct (xs @ e # e' # ys)"
proof -
  have "sorted (e' # ys)"
    "distinct (e' # ys)"
    " y  set (e' # ys). e < y"
    using assms(2,4,5,7)
    by (auto)
  thus "sorted (xs @ e # e' # ys)"
  "distinct (xs @ e # e' # ys)"
    using assms(1,3,6) distinct_sorted_list_lem1[of xs "e' # ys" e]  
    by auto
qed

lemma map_of_distinct_upd:
  "x  set (map fst xs)  [x  y] ++ map_of xs = (map_of xs) (x  y)"
  by (induct xs) (auto simp add: fun_upd_twist)

lemma map_of_distinct_upd2:
  assumes "x  set(map fst xs)"
  "x  set (map fst ys)"
  shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys))(x  y)"
  apply(insert assms)
  apply(induct xs)
  apply (auto intro: ext)
  done

lemma map_of_distinct_upd3:
  assumes "x  set(map fst xs)"
  "x  set (map fst ys)"
  shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ (x,y') # ys))(x  y)"
  apply(insert assms)
  apply(induct xs)
  apply (auto intro: ext)
  done

lemma map_of_distinct_upd4:
  assumes "x  set(map fst xs)"
  "x  set (map fst ys)"
  shows "map_of (xs @ ys) = (map_of (xs @ (x,y) # ys))(x := None)"
  apply(insert assms)
  apply(induct xs)

  apply clarsimp
  apply (metis dom_map_of_conv_image_fst fun_upd_None_restrict 
    restrict_complement_singleton_eq restrict_map_self)

  apply (auto simp add: map_of_eq_None_iff) []
  done

lemma map_of_distinct_lookup:
  assumes "x  set(map fst xs)"
  "x  set (map fst ys)"
  shows "map_of (xs @ (x,y) # ys) x = Some y"
proof -
  have "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys)) (x  y)"
    using assms map_of_distinct_upd2 by simp
  thus ?thesis
    by simp
qed

lemma ran_distinct: 
  assumes dist: "distinct (map fst al)" 
  shows "ran (map_of al) = snd ` set al"
using assms proof (induct al)
  case Nil then show ?case by simp
next
  case (Cons kv al)
  then have "ran (map_of al) = snd ` set al" by simp
  moreover from Cons.prems have "map_of al (fst kv) = None"
    by (simp add: map_of_eq_None_iff)
  ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
qed




subsubsection "Finite"

lemma aluprio_finite_correct: "uprio_finite (aluprio_α α) (aluprio_invar α invar)" 
  by(unfold_locales) (simp add: aluprio_defs finite_dom_map_of)

subsubsection "Empty"
lemma aluprio_empty_correct:
  assumes "al_empty α invar empt"
  shows "uprio_empty (aluprio_α α) (aluprio_invar α invar) (aluprio_empty empt)"
proof -
  interpret al_empty α invar empt by fact
  show ?thesis
    apply (unfold_locales)
    apply (auto simp add: empty_correct aluprio_defs)
    done
qed

subsubsection "Is Empty"

lemma aluprio_isEmpty_correct: 
  assumes "al_isEmpty α invar isEmpty"
  shows "uprio_isEmpty (aluprio_α α) (aluprio_invar α invar) (aluprio_isEmpty isEmpty)"
proof -
  interpret al_isEmpty α invar isEmpty by fact
  show ?thesis 
    apply (unfold_locales) 
    apply (auto simp add: aluprio_defs isEmpty_correct)
    done
qed


subsubsection "Insert"

lemma annot_inf: 
  assumes A: "invar s" "xset (α s). snd x  Infty" "al_annot α invar annot"
  shows "annot s = Infty  α s = [] " 
proof -
  from A have invs: "invar s" by (simp add: aluprio_defs)  
  interpret al_annot α invar annot by fact
  show "annot s = Infty  α s = []"  
  proof (cases "α s = []")
    case True
    hence "map snd (α s) = []" by simp
    hence "sum_list (map snd (α s)) = Infty"  
      by (auto simp add: zero_def)
    with invs have  "annot s = Infty" by (auto simp add: annot_correct)
    with True show ?thesis by simp
  next
    case False
    hence " x xs. (α s) = x # xs" by (cases "α s") auto
    from this obtain x xs where [simp]: "(α s) = x # xs" by blast
    from this assms(2) have "snd x  Infty" by (auto simp add: aluprio_defs)
    hence "sum_list (map snd (α s))  Infty" by (auto simp add: infadd)
    thus ?thesis using annot_correct invs False by simp
  qed
qed

lemma e_less_eq_annot: 
  
  assumes "al_annot α invar annot" 
   "invar s" "xset (α s). snd x  Infty" "¬ e_less_eq e (annot s)"
  shows "x  set (map (fst  (p_unwrap  snd)) (α s)). x < e"
proof -
  interpret al_annot α invar annot by fact
  from assms(2) have "annot s = sum_list (map snd (α s))"
    by (auto simp add: annot_correct)
  with assms(4) have 
    "x  set (map snd (α s)). ¬ e_less_eq e x"
    by (metis e_less_eq_sum_list)
  with assms(3) 
  show ?thesis
    by (auto simp add: e_less_eq_p_unwrap)
qed

lemma aluprio_insert_correct: 
  assumes 
  "al_splits α invar splits"
  "al_annot α invar annot"
  "al_isEmpty α invar isEmpty"
  "al_app α invar app"
  "al_consr α invar consr"
  shows 
  "uprio_insert (aluprio_α α) (aluprio_invar α invar) 
    (aluprio_insert splits annot isEmpty app consr)"
proof -
  interpret al_splits α invar splits by fact
  interpret al_annot α invar annot by fact
  interpret al_isEmpty α invar isEmpty by fact
  interpret al_app α invar app by fact
  interpret al_consr α invar consr by fact
  show ?thesis 
  proof (unfold_locales, unfold aluprio_defs, goal_cases)
    case g1asms: (1 s e a)
    thus ?case proof (cases "e_less_eq e (annot s)  ¬ isEmpty s")
      case False with g1asms show  ?thesis
        apply (auto simp add: consr_correct )
      proof goal_cases
        case prems: 1
        with assms(2) have  
          "x  set (map (fst  (p_unwrap  snd)) (α s)). x < e"
          by (simp add: e_less_eq_annot)
        with prems(3) show ?case
          by(auto simp add: sorted_append)
      next
        case prems: 2
        hence "annot s = sum_list (map snd (α s))" 
          by (simp add: annot_correct)
        with prems
        show ?case 
          by (auto simp add: e_less_eq_sum_list2)
      next
        case prems: 3
        hence "α s = []" by (auto simp add: isEmpty_correct)
        thus ?case by simp
      next
        case prems: 4
        hence "α s = []" by (auto simp add: isEmpty_correct)
        with prems show ?case by simp
      qed
    next
      case True note T1 = this
      obtain l uu lp r where 
        l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
        by (cases "splits (e_less_eq e) Infty s", auto)
      note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
      have 
        v3: "invar s" 
        "¬ e_less_eq e Infty"
        "e_less_eq e (Infty + sum_list (map snd (α s)))"
        using T1 g1asms annot_correct
        by (auto simp add: plus_def)
      have 
        v4: "α s = α l @ ((), lp) # α r"  
        "¬ e_less_eq e (Infty + sum_list (map snd (α l)))"
        "e_less_eq e (Infty + sum_list (map snd (α l)) + lp)"
        "invar l"
        "invar r"
        using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
      hence v5: "e_less_eq e lp"
        by (metis e_less_eq_lem1)
      hence v6: "e  (fst (p_unwrap lp))"
        by (cases lp) auto
      have "(Infty + sum_list (map snd (α l))) = (annot l)"
        by (metis add_0_left annot_correct v4(4) zero_def)
      hence v7:"¬ e_less_eq e (annot l)"
        using v4(2) by simp
      have "xset (α l). snd x  Infty"
        using g1asms v4(1) by simp
      hence v7: "x  set (map (fst  (p_unwrap  snd)) (α l)). x < e"
        using v4(4) v7 assms(2)
        by(simp add: e_less_eq_annot)
      have v8:"map fst (map p_unwrap (map snd (α s))) = 
        map fst (map p_unwrap (map snd (α l))) @ fst(p_unwrap lp) #
        map fst (map p_unwrap (map snd (α r)))"
        using v4(1)
        by simp
      note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (α s)))"
        "map fst (map p_unwrap (map snd (α l)))" "fst(p_unwrap lp)" 
        "map fst (map p_unwrap (map snd (α r)))"]
      hence v9: 
        " xset (map (fst  (p_unwrap  snd)) (α r)). fst(p_unwrap lp) < x"
        using v4(1) g1asms v8
        by auto
      have v10: 
        "sorted (map fst (map p_unwrap (map snd (α l))))"
        "distinct (map fst (map p_unwrap (map snd (α l))))"
        "sorted (map fst (map p_unwrap (map snd (α r))))"
        "distinct (map fst (map p_unwrap (map snd (α l))))"
        using g1asms v8
        by (auto simp add: sorted_append)
      
      from l_lp_r T1 g1asms show ?thesis        
      proof (fold aluprio_insert_def, cases "e < fst (p_unwrap lp)")
        case True
        hence v11: 
          "aluprio_insert splits annot isEmpty app consr s e a 
            = app (consr (consr l () (LP e a)) () lp) r"
          using l_lp_r T1
          by (auto simp add: aluprio_defs)
        have  v12: "invar (app (consr (consr l () (LP e a)) () lp) r)" 
          using v4(4,5)
          by (auto simp add: app_correct consr_correct)
        have v13: 
          "α (app (consr (consr l () (LP e a)) () lp) r) 
            = α l @ ((),(LP e a)) # ((), lp) # α r"
          using v4(4,5) by (auto simp add: app_correct consr_correct)
        hence v14: 
          "(xset (α (app (consr (consr l () (LP e a)) () lp) r)). 
             snd x  Infty)"
          using g1asms v4(1)
          by auto
        have v15: "e = fst(p_unwrap (LP e a))" by simp
        hence v16: 
          "sorted (map fst (map p_unwrap 
             (map snd (α l @ ((),(LP e a)) # ((), lp) # α r))))"              
          "distinct (map fst (map p_unwrap 
             (map snd (α l @ ((),(LP e a)) # ((), lp) # α r))))"              
          using v10(1,3) v7 True v9 v4(1) g1asms distinct_sorted_list_lem2
          by (auto simp add: sorted_append)              
        thus "invar (aluprio_insert splits annot isEmpty app consr s e a) 
          (xset (α (aluprio_insert splits annot isEmpty app consr s e a)). 
             snd x  Infty) 
          sorted (map fst (map p_unwrap (map snd (α 
             (aluprio_insert splits annot isEmpty app consr s e a)))))  
          distinct (map fst (map p_unwrap (map snd (α 
             (aluprio_insert splits annot isEmpty app consr s e a)))))"
          using v11 v12 v13 v14
          by simp
      next
        case False            
        hence v11: 
          "aluprio_insert splits annot isEmpty app consr s e a 
             = app (consr l () (LP e a)) r"
          using l_lp_r T1
          by (auto simp add: aluprio_defs)
        have  v12: "invar (app (consr l () (LP e a)) r)" using v4(4,5)
          by (auto simp add: app_correct consr_correct)
        have v13: "α (app (consr l () (LP e a)) r) = α l @ ((),(LP e a)) # α r"
          using v4(4,5) by (auto simp add: app_correct consr_correct)
        hence v14: "(xset (α (app (consr l () (LP e a)) r)). snd x  Infty)"
          using g1asms v4(1)
          by auto
        have v15: "e = fst(p_unwrap (LP e a))" by simp
        have v16: "e = fst(p_unwrap lp)"
          using False v5 by (cases lp) auto
        hence v17: 
          "sorted (map fst (map p_unwrap 
            (map snd (α l @ ((),(LP e a)) # α r))))"              
          "distinct (map fst (map p_unwrap 
            (map snd (α l @ ((),(LP e a)) # α r))))"              
          using v16 v15 v10(1,3) v7 True v9 v4(1) 
            g1asms distinct_sorted_list_lem1
          by (auto simp add: sorted_append)              
        thus "invar (aluprio_insert splits annot isEmpty app consr s e a) 
          (xset (α (aluprio_insert splits annot isEmpty app consr s e a)). 
            snd x  Infty) 
          sorted (map fst (map p_unwrap (map snd (α 
            (aluprio_insert splits annot isEmpty app consr s e a)))))  
          distinct (map fst (map p_unwrap (map snd (α 
            (aluprio_insert splits annot isEmpty app consr s e a)))))"
          using v11 v12 v13 v14
          by simp
      qed
    qed
  next
    case g1asms: (2 s e a)
    thus ?case proof (cases "e_less_eq e (annot s)  ¬ isEmpty s")
      case False with g1asms show  ?thesis
        apply (auto simp add: consr_correct)
      proof goal_cases
        case prems: 1
        with assms(2) have  
          "x  set (map (fst  (p_unwrap  snd)) (α s)). x < e"
          by (simp add: e_less_eq_annot)
        hence "e  set (map fst ((map (p_unwrap  snd)) (α s)))"
          by auto
        thus ?case
          by (auto simp add: map_of_distinct_upd)
      next
        case prems: 2
        hence "α s = []" by (auto simp add: isEmpty_correct)
        thus ?case
          by simp
      qed
    next
      case True note T1 = this
      obtain l lp r where 
        l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
        by (cases "splits (e_less_eq e) Infty s", auto)
      note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
      have 
        v3: "invar s" 
        "¬ e_less_eq e Infty"
        "e_less_eq e (Infty + sum_list (map snd (α s)))"
        using T1 g1asms annot_correct
        by (auto simp add: plus_def)
      have 
        v4: "α s = α l @ ((), lp) # α r"  
        "¬ e_less_eq e (Infty + sum_list (map snd (α l)))"
        "e_less_eq e (Infty + sum_list (map snd (α l)) + lp)"
        "invar l"
        "invar r"
        using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
      hence v5: "e_less_eq e lp"
        by (metis e_less_eq_lem1)
      hence v6: "e  (fst (p_unwrap lp))"
        by (cases lp) auto
      have "(Infty + sum_list (map snd (α l))) = (annot l)"
        by (metis add_0_left annot_correct v4(4) zero_def)
      hence v7:"¬ e_less_eq e (annot l)"
        using v4(2) by simp
      have "xset (α l). snd x  Infty"
        using g1asms v4(1) by simp
      hence v7: "x  set (map (fst  (p_unwrap  snd)) (α l)). x < e"
        using v4(4) v7 assms(2)
        by(simp add: e_less_eq_annot)
      have v8:"map fst (map p_unwrap (map snd (α s))) = 
        map fst (map p_unwrap (map snd (α l))) @ fst(p_unwrap lp) #
        map fst (map p_unwrap (map snd (α r)))"
        using v4(1)
        by simp
      note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (α s)))"
        "map fst (map p_unwrap (map snd (α l)))" "fst(p_unwrap lp)" 
        "map fst (map p_unwrap (map snd (α r)))"]
      hence v9: "
         xset (map (fst  (p_unwrap  snd)) (α r)). fst(p_unwrap lp) < x"
        using v4(1) g1asms v8
        by auto
      hence v10: "  xset (map (fst  (p_unwrap  snd)) (α r)). e < x"
        using v6 by auto
      have v11: 
        "e  set (map fst (map p_unwrap (map snd (α l))))"
        "e  set (map fst (map p_unwrap (map snd (α r))))"
        using v7 v10 v8 g1asms
        by auto
      from l_lp_r T1 g1asms show ?thesis        
      proof (fold aluprio_insert_def, cases "e < fst (p_unwrap lp)")
        case True
        hence v12: 
          "aluprio_insert splits annot isEmpty app consr s e a 
            = app (consr (consr l () (LP e a)) () lp) r"
          using l_lp_r T1
          by (auto simp add: aluprio_defs)
        have v13: 
          "α (app (consr (consr l () (LP e a)) () lp) r) 
            = α l @ ((),(LP e a)) # ((), lp) # α r"
          using v4(4,5) by (auto simp add: app_correct consr_correct)
        have v14: "e = fst(p_unwrap (LP e a))" by simp
        have v15: "e  set (map fst (map p_unwrap (map snd(((),lp)#α r))))"
          using v11(2) True by auto
        note map_of_distinct_upd2[OF v11(1) v15]
        thus 
          "map_of (map p_unwrap (map snd (α 
              (aluprio_insert splits annot isEmpty app consr s e a)))) 
            = map_of (map p_unwrap (map snd (α s)))(e  a)"
          using v12 v13 v4(1)
          by simp
      next
        case False            
        hence v12: 
          "aluprio_insert splits annot isEmpty app consr s e a 
            = app (consr l () (LP e a)) r"
          using l_lp_r T1
          by (auto simp add: aluprio_defs)
        have v13: 
          "α (app (consr l () (LP e a)) r) = α l @ ((),(LP e a)) # α r"
          using v4(4,5) by (auto simp add: app_correct consr_correct)
        have v14: "e = fst(p_unwrap lp)"
          using False v5 by (cases lp) auto
        note v15 = map_of_distinct_upd3[OF v11(1) v11(2)]
        have v16:"(map p_unwrap (map snd (α s))) = 
          (map p_unwrap (map snd (α l))) @ (e,snd(p_unwrap lp)) #
          (map p_unwrap (map snd (α r)))"
          using v4(1) v14              
          by simp
        note v15[of a "snd(p_unwrap lp)"]         
        thus 
          "map_of (map p_unwrap (map snd (α 
              (aluprio_insert splits annot isEmpty app consr s e a)))) 
            = map_of (map p_unwrap (map snd (α s)))(e  a)"
          using v12 v13 v16
          by simp
      qed
    qed
  qed
qed

subsubsection "Prio"
lemma aluprio_prio_correct: 
  assumes 
  "al_splits α invar splits"
  "al_annot α invar annot"
  "al_isEmpty α invar isEmpty"
  shows 
  "uprio_prio (aluprio_α α) (aluprio_invar α invar) (aluprio_prio splits annot isEmpty)"
proof -
  interpret al_splits α invar splits by fact
  interpret al_annot α invar annot by fact
  interpret al_isEmpty α invar isEmpty by fact
  show ?thesis 
  proof (unfold_locales)
    fix s e
    assume inv1: "aluprio_invar α invar s"
    hence sinv: "invar s" 
      "( xset (α s). snd xInfty)"
      "sorted (map fst (map p_unwrap (map snd (α s))))" 
      "distinct (map fst (map p_unwrap (map snd (α s))))"
      by (auto simp add: aluprio_defs)
    show "aluprio_prio splits annot isEmpty s e = aluprio_α α s e"
    proof(cases "e_less_eq e (annot s)  ¬ isEmpty s")
      case False note F1 = this      
      thus ?thesis
      proof(cases "isEmpty s")
        case True
        hence "α s = []"
          using sinv isEmpty_correct by simp
        hence "aluprio_α α s = Map.empty" by (simp add:aluprio_defs)
        hence "aluprio_α α s e = None" by simp
        thus "aluprio_prio splits annot isEmpty s e = aluprio_α α s e"
          using F1 
          by (auto simp add: aluprio_defs)
      next
        case False
        hence v3:"¬ e_less_eq e (annot s)"  using F1 by simp
        note v4=e_less_eq_annot[OF assms(2)]
        note v4[OF sinv(1) sinv(2) v3]
        hence v5:"eset (map (fst  (p_unwrap  snd)) (α s))"
          by auto
        hence "map_of (map (p_unwrap  snd) (α s)) e = None"
          using map_of_eq_None_iff
          by (metis map_map map_of_eq_None_iff set_map v5) 
        thus "aluprio_prio splits annot isEmpty s e = aluprio_α α s e"
          using F1 
          by (auto simp add: aluprio_defs)
      qed
    next
      case True note T1 = this
      obtain l uu lp r where 
        l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
        by (cases "splits (e_less_eq e) Infty s", auto)
      note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
      have 
        v3: "invar s" 
        "¬ e_less_eq e Infty"
        "e_less_eq e (Infty + sum_list (map snd (α s)))"
        using T1 sinv annot_correct
        by (auto simp add: plus_def)
      have 
        v4: "α s = α l @ ((), lp) # α r"  
        "¬ e_less_eq e (Infty + sum_list (map snd (α l)))"
        "e_less_eq e (Infty + sum_list (map snd (α l)) + lp)"
        "invar l"
        "invar r"
        using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
      hence v5: "e_less_eq e lp"
        by (metis e_less_eq_lem1)
      hence v6: "e  (fst (p_unwrap lp))"
        by (cases lp) auto
      have "(Infty + sum_list (map snd (α l))) = (annot l)"
        by (metis add_0_left annot_correct v4(4) zero_def)
      hence v7:"¬ e_less_eq e (annot l)"
        using v4(2) by simp
      have "xset (α l). snd x  Infty"
        using sinv v4(1) by simp
      hence v7: "x  set (map (fst  (p_unwrap  snd)) (α l)). x < e"
        using v4(4) v7 assms(2)
        by(simp add: e_less_eq_annot)
      have v8:"map fst (map p_unwrap (map snd (α s))) = 
        map fst (map p_unwrap (map snd (α l))) @ fst(p_unwrap lp) #
        map fst (map p_unwrap (map snd (α r)))"
        using v4(1)
        by simp
      note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (α s)))"
        "map fst (map p_unwrap (map snd (α l)))" "fst(p_unwrap lp)" 
        "map fst (map p_unwrap (map snd (α r)))"]
      hence v9: 
        " xset (map (fst  (p_unwrap  snd)) (α r)). fst(p_unwrap lp) < x"
        using v4(1) sinv v8
        by auto
      hence v10: "  xset (map (fst  (p_unwrap  snd)) (α r)). e < x"
        using v6 by auto
      have v11: 
        "e  set (map fst (map p_unwrap (map snd (α l))))"
        "e  set (map fst (map p_unwrap (map snd (α r))))"
        using v7 v10 v8 sinv
        by auto
      from l_lp_r T1 sinv show ?thesis
      proof (cases "e = fst (p_unwrap lp)")
        case False
        have v12: "e  set (map fst (map p_unwrap (map snd(α s))))"
          using v11 False v4(1) by auto
        hence "map_of (map (p_unwrap  snd) (α s)) e = None"
          using map_of_eq_None_iff
          by (metis map_map map_of_eq_None_iff set_map v12)
        thus ?thesis
          using T1 False l_lp_r
          by (auto simp add: aluprio_defs)
      next
        case True
        have v12: "map (p_unwrap  snd) (α s) = 
          map p_unwrap (map snd (α l)) @ (e,snd (p_unwrap lp)) #
          map p_unwrap (map snd (α r))"
          using v4(1) True by simp
        note map_of_distinct_lookup[OF v11]
        hence
          "map_of (map (p_unwrap  snd) (α s)) e = Some (snd (p_unwrap lp))"
          using v12 by simp
        thus ?thesis
          using T1 True l_lp_r
          by (auto simp add: aluprio_defs)
      qed
    qed
  qed
qed
        

subsubsection "Pop"

lemma aluprio_pop_correct: 
  assumes "al_splits α invar splits"
  "al_annot α invar annot"
  "al_app α invar app"
  shows 
  "uprio_pop (aluprio_α α) (aluprio_invar α invar) (aluprio_pop splits annot app)"
proof -
  interpret al_splits α invar splits by fact
  interpret al_annot α invar annot by fact
  interpret al_app α invar app by fact
  show ?thesis 
  proof (unfold_locales)
    fix s e a s'
    assume A: "aluprio_invar α invar s" 
      "aluprio_α α s  Map.empty" 
      "aluprio_pop splits annot app s = (e, a, s')"
    hence v1: "α s  []"
      by (auto simp add: aluprio_defs)
    obtain l lp r where
      l_lp_r: "splits (λ x. xannot s) Infty s = (l,((),lp),r)"
      by (cases "splits (λ x. xannot s) Infty s", auto)
    have invs:
      "invar s" 
      "(xset (α s). snd x  Infty)"
      "sorted (map fst (map p_unwrap (map snd (α s))))"
      "distinct (map fst (map p_unwrap (map snd (α s))))"
      using A by (auto simp add:aluprio_defs)
    note a1 = annot_inf[of invar s α annot]
    note a1[OF invs(1) invs(2) assms(2)]
    hence v2: "annot s  Infty"
      using v1 by simp
    hence v3:
      "¬ Infty  annot s"
      by(cases "annot s") (auto simp add: plesseq_def)
    have v4: "annot s = sum_list (map snd (α s))"
      by (auto simp add: annot_correct invs(1))
    hence 
      v5:
      "(Infty + sum_list (map snd (α s)))  annot s"
      by (auto simp add: plus_def)
    note p_mon = p_less_eq_mon[of _ "annot s"]
    note v6 = splits_correct[OF invs(1)]
    note v7 = v6[of "λ x. x  annot s"]
    note v7[OF _ v3 v5 l_lp_r] p_mon
    hence v8: 
      " α s = α l @ ((), lp) # α r"
      "¬ Infty + sum_list (map snd (α l))  annot s"
      "Infty + sum_list (map snd (α l)) + lp  annot s"
      "invar l"
      "invar r"
      by auto
    hence v9: "lp  Infty"
      using invs(2) by auto
    hence v10: 
      "s' = app l r" 
      "(e,a) = p_unwrap lp"
      using l_lp_r A(3)
      apply (auto simp add: aluprio_defs)
      apply (cases lp)
      apply auto
      apply (cases lp)
      apply auto
      done
    have "lp  annot s"
      using v8(2,3) p_less_eq_lem1
      by auto
    hence v11: "a  snd (p_unwrap (annot s))"
      using v10(2) v2 v9
      apply (cases "annot s")
      apply auto
      apply (cases lp)
      apply (auto simp add: plesseq_def)
      done 
    note sum_list_less_elems[OF invs(2)]
    hence v12: "yset (map snd (map p_unwrap (map snd (α s)))). a  y"
      using v4 v11 by auto
    have "ran (aluprio_α α s) = set (map snd (map p_unwrap (map snd (α s))))"
      using ran_distinct[OF invs(4)]
      apply (unfold aluprio_defs)
      apply (simp only: set_map)
      done
    hence ziel1: "yran (aluprio_α α s). a  y"
      using v12 by simp
    have v13:
      "map p_unwrap (map snd (α s)) 
        = map p_unwrap (map  snd (α l)) @ (e,a) # map p_unwrap (map snd (α r))"
      using v8(1) v10 by auto
     hence v14:
      "map fst (map p_unwrap (map snd (α s))) 
         = map fst (map p_unwrap (map snd (α l))) @ e 
             # map fst (map p_unwrap (map snd (α r)))"
       by auto
    hence v15: 
      "e  set (map fst (map p_unwrap (map snd (α l))))"
      "e  set (map fst (map p_unwrap (map snd (α r))))"
      using invs(4) by auto
    note map_of_distinct_lookup[OF v15]
    note this[of a]
    hence ziel2: "aluprio_α α s e = Some a"
      using  v13
      by (unfold aluprio_defs, auto)
    have v16: 
      "α s' = α l @ α r" 
      "invar s'"
      using v8(4,5) app_correct v10 by auto
    note map_of_distinct_upd4[OF v15]
    note this[of a]
    hence 
      ziel3: "aluprio_α α s' = (aluprio_α α s)(e := None)"
      unfolding aluprio_defs
      using v16(1) v13 by auto
    have ziel4: "aluprio_invar α invar s'"
      using v16 v8(1) invs(2,3,4)
      unfolding aluprio_defs
      by (auto simp add: sorted_append)
    
    show "aluprio_invar α invar s' 
          aluprio_α α s' = (aluprio_α α s)(e := None) 
          aluprio_α α s e = Some a  (yran (aluprio_α α s). a  y)"
      using ziel1 ziel2 ziel3 ziel4 by simp
  qed
qed
    
lemmas aluprio_correct =
  aluprio_finite_correct
  aluprio_empty_correct
  aluprio_isEmpty_correct
  aluprio_insert_correct
  aluprio_pop_correct
  aluprio_prio_correct

locale aluprio_defs = StdALDefs ops 
  for ops :: "(unit,('e::linorder,'a::linorder) LP,'s) alist_ops"
begin
  definition [icf_rec_def]: "aluprio_ops  
    upr_α = aluprio_α α,
    upr_invar = aluprio_invar α invar,
    upr_empty = aluprio_empty empty,
    upr_isEmpty = aluprio_isEmpty isEmpty,
    upr_insert = aluprio_insert splits annot isEmpty app consr,
    upr_pop = aluprio_pop splits annot app,
    upr_prio = aluprio_prio splits annot isEmpty
    "
  
end

locale aluprio = aluprio_defs ops + StdAL ops 
  for ops :: "(unit,('e::linorder,'a::linorder) LP,'s) alist_ops"
begin
  lemma aluprio_ops_impl: "StdUprio aluprio_ops"
    apply (rule StdUprio.intro)
    apply (simp_all add: icf_rec_unf)
    apply (rule aluprio_correct)
    apply (rule aluprio_correct, unfold_locales) []
    apply (rule aluprio_correct, unfold_locales) []
    apply (rule aluprio_correct, unfold_locales) []
    apply (rule aluprio_correct, unfold_locales) []
    apply (rule aluprio_correct, unfold_locales) []
    done
end

end

Theory ICF_Impl_Chapter

(*<*)
theory ICF_Impl_Chapter imports Main begin 
(*>*)
text_raw ‹\isasection{Implementations} \label{ch:Impl}›
(*<*)
end
(*>*)

Theory ListMapImpl

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Map Implementation by Associative Lists}›
theory ListMapImpl
imports 
  "../spec/MapSpec" 
  "../../Lib/Assoc_List" 
  "../gen_algo/MapGA"
begin
text_raw ‹\label{thy:ListMapImpl}›

(*@impl Map
  @type 'a lm
  @abbrv lm,l
  Maps implemented by associative lists. If you need efficient 
  @{text "insert_dj"} operation, you should use list sets with explicit 
  invariants (lmi).
*)

type_synonym ('k,'v) lm = "('k,'v) assoc_list"

definition [icf_rec_def]: "lm_basic_ops  
  bmap_op_α = Assoc_List.lookup,
  bmap_op_invar = λ_. True,
  bmap_op_empty = (λ_::unit. Assoc_List.empty),
  bmap_op_lookup = (λk m. Assoc_List.lookup m k),
  bmap_op_update = Assoc_List.update,
  bmap_op_update_dj = Assoc_List.update,
  bmap_op_delete = Assoc_List.delete,
  bmap_op_list_it = Assoc_List.iteratei
"

setup Locale_Code.open_block
interpretation lm_basic: StdBasicMapDefs lm_basic_ops .
interpretation lm_basic: StdBasicMap lm_basic_ops
  apply unfold_locales
  apply (simp_all add: icf_rec_unf 
    Assoc_List.lookup_empty' Assoc_List.iteratei_correct map_upd_eq_restrict)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lm_ops  lm_basic.dflt_ops"
setup Locale_Code.open_block
interpretation lm: StdMapDefs lm_ops .
interpretation lm: StdMap lm_ops 
  unfolding lm_ops_def
  by (rule lm_basic.dflt_ops_impl)
interpretation lm: StdMap_no_invar lm_ops 
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "lm"

lemma pi_lm[proper_it]: 
  "proper_it' Assoc_List.iteratei Assoc_List.iteratei"
  unfolding Assoc_List.iteratei_def[abs_def]
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lm: proper_it_loc Assoc_List.iteratei Assoc_List.iteratei
  apply unfold_locales
  apply (rule pi_lm)
  done

lemma pi_lm'[proper_it]: 
  "proper_it' lm.iteratei lm.iteratei"
  unfolding lm.iteratei_def[abs_def]
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lm': proper_it_loc lm.iteratei lm.iteratei
  apply unfold_locales
  apply (rule pi_lm')
  done


text ‹Code generator test›
definition "test_codegen  (
  lm.add ,
  lm.add_dj ,
  lm.ball ,
  lm.bex ,
  lm.delete ,
  lm.empty ,
  lm.isEmpty ,
  lm.isSng ,
  lm.iterate ,
  lm.iteratei ,
  lm.list_it ,
  lm.lookup ,
  lm.restrict ,
  lm.sel ,
  lm.size ,
  lm.size_abort ,
  lm.sng ,
  lm.to_list ,
  lm.to_map ,
  lm.update ,
  lm.update_dj)"

export_code test_codegen checking SML

end

Theory ListMapImpl_Invar

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Map Implementation by Association Lists with explicit invariants}›
theory ListMapImpl_Invar
imports 
  "../spec/MapSpec"
  "../../Lib/Assoc_List" 
  "../gen_algo/MapGA"
begin
text_raw ‹\label{thy:ListMapImpl_Invar}›

(*@impl Map
  @type 'a lmi
  @abbrv lmi,l
  Maps implemented by associative lists. Version with explicit 
  invariants that allows for efficient xxx-dj operations.
*)

type_synonym ('k,'v) lmi = "('k×'v) list"

term revg

definition "lmi_α  Map.map_of"
definition "lmi_invar  λm. distinct (List.map fst m)"

definition lmi_basic_ops :: "('k,'v,('k,'v) lmi) map_basic_ops"
  where [icf_rec_def]: "lmi_basic_ops  
  bmap_op_α = lmi_α,
  bmap_op_invar = lmi_invar,
  bmap_op_empty = (λ_::unit. []),
  bmap_op_lookup = (λk m. Map.map_of m k),
  bmap_op_update = AList.update,
  bmap_op_update_dj = (λk v m. (k, v) # m),
  bmap_op_delete = AList.delete_aux,
  bmap_op_list_it = foldli
"


setup Locale_Code.open_block
interpretation lmi_basic: StdBasicMapDefs lmi_basic_ops .
interpretation lmi_basic: StdBasicMap lmi_basic_ops 
  unfolding lmi_basic_ops_def
  apply unfold_locales
  apply (simp_all 
    add: icf_rec_unf lmi_α_def lmi_invar_def 
    add: AList.update_conv' AList.distinct_update AList.map_of_delete_aux'
      map_iterator_foldli_correct dom_map_of_conv_image_fst map_upd_eq_restrict
  )
  done
setup Locale_Code.close_block


definition [icf_rec_def]: "lmi_ops  lmi_basic.dflt_ops 
  map_op_add_dj := revg,
  map_op_to_list := id,
  map_op_size := length,
  map_op_isEmpty := case_list True (λ_ _. False),
  map_op_isSng := (λl. case l of [_]  True | _  False)
"

setup Locale_Code.open_block
interpretation lmi: StdMapDefs lmi_ops .
interpretation lmi: StdMap lmi_ops 
proof -
  interpret aux: StdMap lmi_basic.dflt_ops by (rule lmi_basic.dflt_ops_impl)

  have [simp]: "map_add_dj lmi_α lmi_invar revg"
    apply (unfold_locales)
    apply (auto simp: lmi_α_def lmi_invar_def)
    apply (blast intro: map_add_comm)
    apply (simp add: rev_map[symmetric])
    apply fastforce
    done

  have [simp]: "map_to_list lmi_α lmi_invar id"
    apply unfold_locales
    by (simp_all add: lmi_α_def lmi_invar_def)

  have [simp]: "map_isEmpty lmi_α lmi_invar (case_list True (λ_ _. False))"
    apply unfold_locales
    unfolding lmi_α_def lmi_invar_def
    by (simp split: list.split)

  have [simp]: "map_isSng lmi_α lmi_invar
     (λl. case l of [_]  True | _  False)"
    apply unfold_locales
    unfolding lmi_α_def lmi_invar_def
    apply (auto split: list.split)
    apply (metis (no_types) map_upd_nonempty)
    by (metis fun_upd_other fun_upd_same option.simps(3))

  have [simp]: "map_size_axioms lmi_α lmi_invar length" 
    apply unfold_locales
    unfolding lmi_α_def lmi_invar_def
    by (metis card_dom_map_of)

  show "StdMap lmi_ops"
    unfolding lmi_ops_def
    apply (rule StdMap_intro)
    apply (simp_all)
    apply intro_locales
    apply (simp_all add: icf_rec_unf)
    done
qed
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "lmi"

lemma pi_lmi[proper_it]: 
  "proper_it' foldli foldli"
  by (intro proper_it'I icf_proper_iteratorI)

interpretation pi_lmi: proper_it_loc foldli foldli
  apply unfold_locales
  apply (rule pi_lmi)
  done

definition lmi_from_list_dj :: "('k×'v) list  ('k,'v) lmi" where
  "lmi_from_list_dj  id"

lemma lmi_from_list_dj_correct: 
  assumes [simp]: "distinct (map fst l)"
  shows "lmi.α (lmi_from_list_dj l) = map_of l"
        "lmi.invar (lmi_from_list_dj l)"
  by (auto simp add: lmi_from_list_dj_def icf_rec_unf lmi_α_def lmi_invar_def)

text ‹Code generator test›
definition "test_codegen  (
  lmi.add ,
  lmi.add_dj ,
  lmi.ball ,
  lmi.bex ,
  lmi.delete ,
  lmi.empty ,
  lmi.isEmpty ,
  lmi.isSng ,
  lmi.iterate ,
  lmi.iteratei ,
  lmi.list_it ,
  lmi.lookup ,
  lmi.restrict ,
  lmi.sel ,
  lmi.size ,
  lmi.size_abort ,
  lmi.sng ,
  lmi.to_list ,
  lmi.to_map ,
  lmi.update ,
  lmi.update_dj,
  lmi_from_list_dj
  )"

export_code test_codegen checking SML

end

Theory RBTMapImpl

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changelist since submission on 2009-11-26:

  2009-12-09: Ordered iterators, to_list produces sorted list


*)
section ‹\isaheader{Map Implementation by Red-Black-Trees}›
theory RBTMapImpl
imports 
  "../spec/MapSpec"
  "../../Lib/RBT_add" 
  "HOL-Library.RBT"
  "../gen_algo/MapGA"
begin
text_raw ‹\label{thy:RBTMapImpl}›

hide_const (open) RBT.map RBT.fold RBT.foldi RBT.empty RBT.insert

(*@impl Map
  @type ('k::linorder,'v) rm 
  @abbrv rm,r
  Maps over linearly ordered keys implemented by red-black trees.
*)

type_synonym ('k,'v) rm = "('k,'v) RBT.rbt"

definition rm_basic_ops :: "('k::linorder,'v,('k,'v) rm) omap_basic_ops"
  where [icf_rec_def]: "rm_basic_ops  
  bmap_op_α = RBT.lookup,
  bmap_op_invar = λ_. True,
  bmap_op_empty = (λ_::unit. RBT.empty),
  bmap_op_lookup = (λk m. RBT.lookup m k),
  bmap_op_update = RBT.insert,
  bmap_op_update_dj = RBT.insert,
  bmap_op_delete = RBT.delete,
  bmap_op_list_it = (λr. RBT_add.rm_iterateoi (RBT.impl_of r)),
  bmap_op_ordered_list_it = (λr. RBT_add.rm_iterateoi (RBT.impl_of r)),
  bmap_op_rev_list_it = (λr. RBT_add.rm_reverse_iterateoi (RBT.impl_of r))
"

setup Locale_Code.open_block
interpretation rm_basic: StdBasicOMap rm_basic_ops
  apply unfold_locales
  apply (simp_all add: rm_basic_ops_def map_upd_eq_restrict)
  apply (rule map_iterator_linord_is_it)
  apply dup_subgoals
  unfolding RBT.lookup_def
  apply simp_all
  apply (rule rm_iterateoi_correct)
  apply simp
  apply (rule rm_reverse_iterateoi_correct)
  apply simp
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "rm_ops  rm_basic.dflt_oopsmap_op_add := RBT.union"
setup Locale_Code.open_block
interpretation rm: StdOMap rm_ops 
proof -
  interpret aux1: StdOMap rm_basic.dflt_oops
    unfolding rm_ops_def
    by (rule rm_basic.dflt_oops_impl)
  interpret aux2: map_add RBT.lookup "λ_. True" RBT.union
    apply unfold_locales
    apply (rule lookup_union)
    .

  show "StdOMap rm_ops"
    apply (rule StdOMap_intro)
    apply icf_locales
    done
qed

interpretation rm: StdMap_no_invar rm_ops 
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "rm"

lemma pi_rm[proper_it]: 
  "proper_it' RBT_add.rm_iterateoi RBT_add.rm_iterateoi"
  apply (rule proper_it'I)
  by (induct_tac s) (simp_all add: rm_iterateoi_alt_def icf_proper_iteratorI)
lemma pi_rm_rev[proper_it]: 
  "proper_it' RBT_add.rm_reverse_iterateoi RBT_add.rm_reverse_iterateoi"
  apply (rule proper_it'I)
  by (induct_tac s) (simp_all add: rm_reverse_iterateoi_alt_def 
    icf_proper_iteratorI)

interpretation pi_rm: proper_it_loc RBT_add.rm_iterateoi RBT_add.rm_iterateoi
  apply unfold_locales by (rule pi_rm)
interpretation pi_rm_rev: proper_it_loc RBT_add.rm_reverse_iterateoi
  RBT_add.rm_reverse_iterateoi
  apply unfold_locales by (rule pi_rm_rev)

text ‹Code generator test›
definition "test_codegen  (rm.add ,
  rm.add_dj ,
  rm.ball ,
  rm.bex ,
  rm.delete ,
  rm.empty ,
  rm.isEmpty ,
  rm.isSng ,
  rm.iterate ,
  rm.iteratei ,
  rm.iterateo ,
  rm.iterateoi ,
  rm.list_it ,
  rm.lookup ,
  rm.max ,
  rm.min ,
  rm.restrict ,
  rm.rev_iterateo ,
  rm.rev_iterateoi ,
  rm.rev_list_it ,
  rm.reverse_iterateo ,
  rm.reverse_iterateoi ,
  rm.sel ,
  rm.size ,
  rm.size_abort ,
  rm.sng ,
  rm.to_list ,
  rm.to_map ,
  rm.to_rev_list ,
  rm.to_sorted_list ,
  rm.update ,
  rm.update_dj)"

export_code test_codegen checking SML

end

Theory HashMap_Impl

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Hash maps implementation}›
theory HashMap_Impl
imports 
  RBTMapImpl 
  ListMapImpl
  "../../Lib/HashCode"
  "../../Lib/Code_Target_ICF"
begin

text ‹
  We use a red-black tree instead of an indexed array. This
  has the disadvantage of being more complex, however we need not bother
  about a fixed-size array and rehashing if the array becomes too full.

  The entries of the red-black tree are lists of (key,value) pairs.
›

subsection ‹Abstract Hashmap›
text ‹
  We first specify the behavior of our hashmap on the level of maps.
  We will then show that our implementation based on hashcode-map and bucket-map 
  is a correct implementation of this specification.
›
type_synonym 
  ('k,'v) abs_hashmap = "hashcode  ('k  'v)"

  ― ‹Map entry of map by function›
abbreviation map_entry where "map_entry k f m == m(k := f (m k))"


  ― ‹Invariant: Buckets only contain entries with the right hashcode and there are no empty buckets›
definition ahm_invar:: "('k::hashable,'v) abs_hashmap  bool" 
  where "ahm_invar m == 
    (hc cm k. m hc = Some cm  kdom cm  hashcode k = hc)  
    (hc cm. m hc = Some cm  cm  Map.empty)"



  ― ‹Abstract a hashmap to the corresponding map›
definition ahm_α where
  "ahm_α m k == case m (hashcode k) of 
    None  None |
    Some cm  cm k"

  ― ‹Lookup an entry›
definition ahm_lookup :: "'k::hashable  ('k,'v) abs_hashmap  'v option" 
  where "ahm_lookup k m == (ahm_α m) k"

  ― ‹The empty hashmap›
definition ahm_empty :: "('k::hashable,'v) abs_hashmap" 
  where "ahm_empty = Map.empty"

  ― ‹Update/insert an entry›
definition ahm_update where
  "ahm_update k v m ==
    case m (hashcode k) of
      None  m (hashcode k  [k  v]) |
      Some cm  m (hashcode k  cm (k  v))
  "

  ― ‹Delete an entry›
definition ahm_delete where 
  "ahm_delete k m == map_entry (hashcode k) 
    (λv. case v of 
      None  None | 
      Some bm  (
        if bm |` (- {k}) = Map.empty then
          None
        else
          Some ( bm |` (- {k}))
      )
    ) m
  "

definition ahm_isEmpty where
  "ahm_isEmpty m == m=Map.empty"

text ‹
  Now follow correctness lemmas, that relate the hashmap operations to
  operations on the corresponding map. Those lemmas are named op\_correct, where
  (is) the operation.
›

lemma ahm_invarI: " 
  !!hc cm k. m hc = Some cm; kdom cm  hashcode k = hc;
  !!hc cm.  m hc = Some cm   cm  Map.empty
    ahm_invar m"
  by (unfold ahm_invar_def) blast

lemma ahm_invarD: " ahm_invar m; m hc = Some cm; kdom cm   hashcode k = hc"
  by (unfold ahm_invar_def) blast

lemma ahm_invarDne: " ahm_invar m; m hc = Some cm   cm  Map.empty"
  by (unfold ahm_invar_def) blast

lemma ahm_invar_bucket_not_empty[simp]: 
  "ahm_invar m  m hc  Some Map.empty"
  by (auto dest: ahm_invarDne)

lemmas ahm_lookup_correct = ahm_lookup_def

lemma ahm_empty_correct: 
  "ahm_α ahm_empty = Map.empty"
  "ahm_invar ahm_empty"
  apply (rule ext)
  apply (unfold ahm_empty_def) 
  apply (auto simp add: ahm_α_def intro: ahm_invarI split: option.split)
  done


lemma ahm_update_correct: 
  "ahm_α (ahm_update k v m) = ahm_α m (k  v)"
  "ahm_invar m  ahm_invar (ahm_update k v m)"
  apply (rule ext)
  apply (unfold ahm_update_def)
  apply (auto simp add: ahm_α_def split: option.split)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD ahm_invarDne split: if_split_asm)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD split: if_split_asm)
  apply (drule (1) ahm_invarD)
  apply auto
  done

lemma fun_upd_apply_ne: "xy  (f(x:=v)) y = f y"
  by simp

lemma cancel_one_empty_simp: "m |` (-{k}) = Map.empty  dom m  {k}"
proof
  assume "m |` (- {k}) = Map.empty"
  hence "{} = dom (m |` (-{k}))" by auto
  also have " = dom m - {k}" by auto
  finally show "dom m  {k}" by blast
next
  assume "dom m  {k}"
  hence "dom m - {k} = {}" by auto
  hence "dom (m |` (-{k})) = {}" by auto
  thus "m |` (-{k}) = Map.empty" by blast
qed
  
lemma ahm_delete_correct: 
  "ahm_α (ahm_delete k m) = (ahm_α m) |` (-{k})"
  "ahm_invar m  ahm_invar (ahm_delete k m)"
  apply (rule ext)
  apply (unfold ahm_delete_def)
  apply (auto simp add: ahm_α_def Let_def Map.restrict_map_def 
              split: option.split)[1]
  apply (drule_tac x=x in fun_cong)
  apply (auto)[1]
  apply (rule ahm_invarI)
  apply (auto split: if_split_asm option.split_asm dest: ahm_invarD)
  apply (drule (1) ahm_invarD)
  apply (auto simp add: restrict_map_def split: if_split_asm option.split_asm)
  done

lemma ahm_isEmpty_correct: "ahm_invar m  ahm_isEmpty m  ahm_α m = Map.empty"
proof
  assume "ahm_invar m" "ahm_isEmpty m"
  thus "ahm_α m = Map.empty"
    by (auto simp add: ahm_isEmpty_def ahm_α_def intro: ext)
next
  assume I: "ahm_invar m" 
    and E: "ahm_α m = Map.empty"

  show "ahm_isEmpty m"
  proof (rule ccontr)
    assume "¬ahm_isEmpty m"
    then obtain hc bm where MHC: "m hc = Some bm"
      by (unfold ahm_isEmpty_def)
         (blast elim: nempty_dom dest: domD)
    from ahm_invarDne[OF I, OF MHC] obtain k v where
      BMK: "bm k = Some v"
      by (blast elim: nempty_dom dest: domD)
    from ahm_invarD[OF I, OF MHC] BMK have [simp]: "hashcode k = hc"
      by auto
    hence "ahm_α m k = Some v"
      by (simp add: ahm_α_def MHC BMK)
    with E show False by simp
  qed
qed

lemmas ahm_correct = ahm_empty_correct ahm_lookup_correct ahm_update_correct 
                     ahm_delete_correct ahm_isEmpty_correct

  ― ‹Bucket entries correspond to map entries›
lemma ahm_be_is_e:
  assumes I: "ahm_invar m"
  assumes A: "m hc = Some bm" "bm k = Some v"
  shows "ahm_α m k = Some v"
  using A
  apply (auto simp add: ahm_α_def split: option.split dest: ahm_invarD[OF I])
  apply (frule ahm_invarD[OF I, where k=k])
  apply auto
  done

  ― ‹Map entries correspond to bucket entries›
lemma ahm_e_is_be: "
  ahm_α m k = Some v; 
  !!bm. m (hashcode k) = Some bm; bm k = Some v   P
    P"
  by (unfold ahm_α_def)
     (auto split: option.split_asm)

subsection ‹Concrete Hashmap›
text ‹
  In this section, we define the concrete hashmap that is made from the 
  hashcode map and the bucket map.

  We then show the correctness of the operations w.r.t. the abstract hashmap, and
  thus, indirectly, w.r.t. the corresponding map.
›

type_synonym
  ('k,'v) hm_impl = "(hashcode, ('k,'v) lm) rm"

subsubsection "Operations"

  ― ‹Auxiliary function: Apply function to value of an entry›
definition rm_map_entry 
  :: "hashcode  ('v option  'v option)  (hashcode, 'v) rm  (hashcode,'v) rm" 
  where 
  "rm_map_entry k f m ==
      case rm.lookup k m of
        None  (
          case f None of 
            None  m |
            Some v  rm.update k v m
        ) |
        Some v  (
          case f (Some v) of
            None  rm.delete k m |
            Some v'  rm.update k v' m
        )
    "

  ― ‹Empty hashmap›
definition empty :: "unit  ('k :: hashable, 'v) hm_impl" where "empty == rm.empty"

  ― ‹Update/insert entry›
definition update :: "'k::hashable  'v  ('k,'v) hm_impl  ('k,'v) hm_impl"
  where 
  "update k v m == 
   let hc = hashcode k in
     case rm.lookup hc m of
       None  rm.update hc (lm.update k v (lm.empty ())) m |
       Some bm  rm.update hc (lm.update k v bm) m" 

  ― ‹Lookup value by key›
definition lookup :: "'k::hashable  ('k,'v) hm_impl  'v option" where
  "lookup k m ==
   case rm.lookup (hashcode k) m of
     None  None |
     Some lm  lm.lookup k lm"

  ― ‹Delete entry by key›
definition delete :: "'k::hashable  ('k,'v) hm_impl  ('k,'v) hm_impl" where
  "delete k m ==
   rm_map_entry (hashcode k) 
     (λv. case v of 
       None  None | 
       Some lm  (
         let lm' = lm.delete k lm 
         in  if lm.isEmpty lm' then None else Some lm'
       )
     ) m"

  ― ‹Emptiness check›
definition "isEmpty == rm.isEmpty"

  ― ‹Interruptible iterator›
definition "iteratei m c f σ0 ==
  rm.iteratei m c (λ(hc, lm) σ. 
    lm.iteratei lm c f σ
  ) σ0"

lemma iteratei_alt_def :
  "iteratei m = set_iterator_image snd (
     set_iterator_product (rm.iteratei m) (λhclm. lm.iteratei (snd hclm)))"
proof -
  have aux: "c f. (λ(hc, lm). lm.iteratei lm c f) = (λm. lm.iteratei (snd m) c f)"
    by auto
  show ?thesis
    unfolding set_iterator_product_def set_iterator_image_alt_def 
      iteratei_def[abs_def] aux
    by (simp add: split_beta)
qed


subsubsection "Correctness w.r.t. Abstract HashMap"
text ‹
  The following lemmas establish the correctness of the operations w.r.t. the 
  abstract hashmap.

  They have the naming scheme op\_correct', where (is) the name of the 
  operation.
›

  ― ‹Abstract concrete hashmap to abstract hashmap›
definition hm_α' where "hm_α' m == λhc. case rm.α m hc of
  None  None |
  Some lm  Some (lm.α lm)"

  ― ‹Invariant for concrete hashmap: 
    The hashcode-map and bucket-maps satisfy their invariants and
    the invariant of the corresponding abstract hashmap is satisfied.›

definition "invar m == ahm_invar (hm_α' m)"

lemma rm_map_entry_correct:
  "rm.α (rm_map_entry k f m) = (rm.α m)(k := f (rm.α m k))"
  apply (auto 
    simp add: rm_map_entry_def rm.delete_correct rm.lookup_correct rm.update_correct 
    split: option.split)
  done

lemma empty_correct': 
  "hm_α' (empty ()) = ahm_empty"
  "invar (empty ())"
  by (simp_all add: hm_α'_def empty_def ahm_empty_def rm.correct invar_def ahm_invar_def)

lemma lookup_correct': 
  "invar m  lookup k m = ahm_lookup k (hm_α' m)"
  apply (unfold lookup_def invar_def)
  apply (auto split: option.split 
              simp add: ahm_lookup_def ahm_α_def hm_α'_def 
                        rm.correct lm.correct)
  done

lemma update_correct': 
  "invar m  hm_α' (update k v m) = ahm_update k v (hm_α' m)"
  "invar m  invar (update k v m)"
proof -
  assume "invar m"
  thus "hm_α' (update k v m) = ahm_update k v (hm_α' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: update_def ahm_update_def hm_α'_def Let_def 
                          rm.correct lm.correct 
                split: option.split)
    done
  thus "invar m  invar (update k v m)"
    by (simp add: invar_def ahm_update_correct)
qed

lemma delete_correct':
  "invar m  hm_α' (delete k m) = ahm_delete k (hm_α' m)"
  "invar m  invar (delete k m)"
proof -
  assume "invar m"
  thus "hm_α' (delete k m) = ahm_delete k (hm_α' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: delete_def ahm_delete_def hm_α'_def 
                          rm_map_entry_correct
                          rm.correct lm.correct Let_def 
                split: option.split option.split_asm)
    done
  thus "invar (delete k m)" using ‹invar m
    by (simp add: ahm_delete_correct invar_def)
qed

lemma isEmpty_correct':
  "invar hm  isEmpty hm  ahm_α (hm_α' hm) = Map.empty"
apply (simp add: isEmpty_def rm.isEmpty_correct invar_def
                 ahm_isEmpty_correct[unfolded ahm_isEmpty_def, symmetric])
by (auto simp add: hm_α'_def ahm_α_def fun_eq_iff split: option.split_asm)

(*
lemma sel_correct':
  assumes "invar hm"
  shows "⟦ sel hm f = Some r; ⋀u v. ⟦ ahm_α (hm_α' hm) u = Some v; f (u, v) = Some r ⟧ ⟹ P ⟧ ⟹ P"
  and "⟦ sel hm f = None; ahm_α (hm_α' hm) u = Some v ⟧ ⟹ f (u, v) = None"
proof -
  assume sel: "sel hm f = Some r"
    and P: "⋀u v. ⟦ahm_α (hm_α' hm) u = Some v; f (u, v) = Some r⟧ ⟹ P"
  from `invar hm` have IA: "ahm_invar (hm_α' hm)" by(simp add: invar_def)
  from TrueI sel obtain hc lm where "rm_α hm hc = Some lm"
    and "lm_sel lm f = Some r"
    unfolding sel_def by (rule rm.sel_someE) simp
  from TrueI `lm_sel lm f = Some r`
  obtain k v where "lm_α lm k = Some v" "f (k, v) = Some r"
    by(rule lm.sel_someE)
  from `rm_α hm hc = Some lm` have "hm_α' hm hc = Some (lm_α lm)"
    by(simp add: hm_α'_def)
  with IA have "ahm_α (hm_α' hm) k = Some v" using `lm_α lm k = Some v`
    by(rule ahm_be_is_e)
  thus P using `f (k, v) = Some r` by(rule P)
next
  assume sel: "sel hm f = None" 
    and α: "ahm_α (hm_α' hm) u = Some v"
  from `invar hm` have IA: "ahm_invar (hm_α' hm)" by(simp add: invar_def)
  from α obtain lm where α_u: "hm_α' hm (hashcode u) = Some lm"
    and "lm u = Some v" by (rule ahm_e_is_be)
  from α_u obtain lmc where "rm_α hm (hashcode u) = Some lmc" "lm = lm_α lmc" 
    by(auto simp add: hm_α'_def split: option.split_asm)
  with `lm u = Some v` have "lm_α lmc u = Some v" by simp
  from sel rm.sel_noneD [OF TrueI _ `rm_α hm (hashcode u) = Some lmc`, 
         of "(λ(hc, lm). lm_sel lm f)"]
  have "lm_sel lmc f = None" unfolding sel_def by simp  
  with TrueI show "f (u, v) = None" using `lm_α lmc u = Some v` by(rule lm.sel_noneD)
qed
*)

lemma iteratei_correct':
  assumes invar: "invar hm"
  shows "map_iterator (iteratei hm) (ahm_α (hm_α' hm))"
proof -
  from rm.iteratei_correct
  have it_rm: "map_iterator (rm.iteratei hm) (rm.α hm)" by simp

  from lm.iteratei_correct
  have it_lm: "lm. map_iterator (lm.iteratei lm) (lm.α lm)" by simp
 
  from set_iterator_product_correct 
    [OF it_rm, of "λhclm. lm.iteratei (snd hclm)"
     "λhclm. map_to_set (lm.α (snd hclm))", OF it_lm]
  have it_prod: "set_iterator
         (set_iterator_product (rm.iteratei hm) (λhclm. lm.iteratei (snd hclm)))
         (SIGMA hclm:map_to_set (rm.α hm). map_to_set (lm.α (snd hclm)))" 
    by simp
 
  show ?thesis unfolding iteratei_alt_def
  proof (rule set_iterator_image_correct[OF it_prod])
    from invar
    show "inj_on snd
       (SIGMA hclm:map_to_set (rm.α hm). map_to_set (lm.α (snd hclm)))"
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_α'_def Ball_def 
                       map_to_set_def split: option.splits)
      apply (metis domI option.inject)
    done
  next
    from invar
    show "map_to_set (ahm_α (hm_α' hm)) =
          snd ` (SIGMA hclm:map_to_set (rm.α hm). map_to_set (lm.α (snd hclm)))" 
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_α'_def Ball_def 
                       map_to_set_def set_eq_iff image_iff split: option.splits)
      apply (auto simp add: dom_def ahm_α_def split: option.splits)
    done
  qed
qed


lemmas hm_correct' = empty_correct' lookup_correct' update_correct' 
                     delete_correct' isEmpty_correct' 
                     iteratei_correct'
lemmas hm_invars = empty_correct'(2) update_correct'(2) 
                   delete_correct'(2)

hide_const (open) empty invar lookup update delete isEmpty iteratei

end

Theory HashMap

(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section ‹\isaheader{Hash Maps}›
theory HashMap 
  imports HashMap_Impl 
begin
text_raw ‹\label{thy:HashMap}›

(*@impl Map
  @type 'a::hashable hm
  @abbrv hm,h
  Hash maps based on red-black trees.
*)

subsection "Type definition"

typedef (overloaded) ('k, 'v) hashmap = "{hm :: ('k :: hashable, 'v) hm_impl. HashMap_Impl.invar hm}"
  morphisms impl_of_RBT_HM RBT_HM
proof
  show "HashMap_Impl.empty ()  {hm. HashMap_Impl.invar hm}"
    by(simp add: HashMap_Impl.empty_correct')
qed

lemma impl_of_RBT_HM_invar [simp, intro!]: "HashMap_Impl.invar (impl_of_RBT_HM hm)"
using impl_of_RBT_HM[of hm] by simp

lemma RBT_HM_imp_of_RBT_HM [code abstype]:
  "RBT_HM (impl_of_RBT_HM hm) = hm"
by(fact impl_of_RBT_HM_inverse)

definition hm_empty_const :: "('k :: hashable, 'v) hashmap"
where "hm_empty_const = RBT_HM (HashMap_Impl.empty ())"

definition hm_empty :: "unit  ('k :: hashable, 'v) hashmap"
where "hm_empty = (λ_. hm_empty_const)"

definition "hm_lookup k hm == HashMap_Impl.lookup k (impl_of_RBT_HM hm)"

definition hm_update :: "('k :: hashable)  'v  ('k, 'v) hashmap  ('k, 'v) hashmap"
where "hm_update k v hm = RBT_HM (HashMap_Impl.update k v (impl_of_RBT_HM hm))"

definition hm_update_dj :: "('k :: hashable)  'v  ('k, 'v) hashmap  ('k, 'v) hashmap"
where "hm_update_dj = hm_update"

definition hm_delete :: "('k :: hashable)  ('k, 'v) hashmap  ('k, 'v) hashmap"
where "hm_delete k hm = RBT_HM (HashMap_Impl.delete k (impl_of_RBT_HM hm))"

definition hm_isEmpty :: "('k :: hashable, 'v) hashmap  bool"
where "hm_isEmpty hm = HashMap_Impl.isEmpty (impl_of_RBT_HM hm)"

(*definition hm_sel :: "('k :: hashable, 'v) hashmap ⇒ ('k × 'v ⇀ 'a) ⇀ 'a"
  where "hm_sel hm = HashMap_Impl.sel (impl_of_RBT_HM hm)"*)

(*definition "hm_sel' = MapGA.sel_sel' hm_sel"*)

definition "hm_iteratei hm == HashMap_Impl.iteratei (impl_of_RBT_HM hm)"

lemma impl_of_hm_empty [simp, code abstract]:
  "impl_of_RBT_HM (hm_empty_const) = HashMap_Impl.empty ()"
by(simp add: hm_empty_const_def empty_correct' RBT_HM_inverse)

lemma impl_of_hm_update [simp, code abstract]:
  "impl_of_RBT_HM (hm_update k v hm) = HashMap_Impl.update k v (impl_of_RBT_HM hm)"
by(simp add: hm_update_def update_correct' RBT_HM_inverse)

lemma impl_of_hm_delete [simp, code abstract]:
  "impl_of_RBT_HM (hm_delete k hm) = HashMap_Impl.delete k (impl_of_RBT_HM hm)"
by(simp add: hm_delete_def delete_correct' RBT_HM_inverse)

subsection "Correctness w.r.t. Map"
text ‹
  The next lemmas establish the correctness of the hashmap operations w.r.t. the 
  associated map. This is achieved by chaining the correctness lemmas of the 
  concrete hashmap w.r.t. the abstract hashmap and the correctness lemmas of the
  abstract hashmap w.r.t. maps.
›

type_synonym ('k, 'v) hm = "('k, 'v) hashmap"

  ― ‹Abstract concrete hashmap to map›
definition "hm_α == ahm_α  hm_α'  impl_of_RBT_HM"

abbreviation (input) hm_invar :: "('k :: hashable, 'v) hashmap  bool"
where "hm_invar == λ_. True"


lemma hm_aux_correct:
  "hm_α (hm_empty ()) = Map.empty "
  "hm_lookup k m = hm_α m k"
  "hm_α (hm_update k v m) = (hm_α m)(kv)"
  "hm_α (hm_delete k m) = (hm_α m) |` (-{k})"
by(auto simp add: hm_α_def hm_correct' hm_empty_def ahm_correct hm_lookup_def)

lemma hm_finite[simp, intro!]:
  "finite (dom (hm_α m))"
proof(cases m)
  case (RBT_HM m')
  hence SS: "dom (hm_α m)  { dom (lm.α lm) | lm hc. rm.α m' hc = Some lm }"
    apply(clarsimp simp add: RBT_HM_inverse hm_α_def hm_α'_def [abs_def] ahm_α_def [abs_def])
    apply(auto split: option.split_asm option.split)
    done
  moreover have "finite " (is "finite (?A)")
  proof
    have "{ dom (lm.α lm) | lm hc. rm.α m' hc = Some lm } 
           (λhc. dom (lm.α (the (rm.α m' hc)) )) ` (dom (rm.α m'))" 
      (is "?S  _")
      by force
    thus "finite ?A" by(rule finite_subset) auto
  next
    fix M
    assume "M  ?A"
    thus "finite M" by auto
  qed
  ultimately show ?thesis unfolding RBT_HM by(rule finite_subset)
qed


lemma hm_iteratei_impl: 
  "map_iterator (hm_iteratei m) (hm_α m)"
  apply (unfold hm_α_def hm_iteratei_def o_def)
  apply(rule iteratei_correct'[OF impl_of_RBT_HM_invar])
  done

subsection "Integration in Isabelle Collections Framework"
text ‹
  In this section, we integrate hashmaps into the Isabelle Collections Framework.
›



definition [icf_rec_def]: "hm_basic_ops  
  bmap_op_α = hm_α,
  bmap_op_invar = λ_. True,
  bmap_op_empty = hm_empty,
  bmap_op_lookup = hm_lookup,
  bmap_op_update = hm_update,
  bmap_op_update_dj = hm_update, ― ‹TODO: Optimize bucket-ins here›
  bmap_op_delete = hm_delete,
  bmap_op_list_it = hm_iteratei
"


setup Locale_Code.open_block
interpretation hm_basic: StdBasicMap hm_basic_ops
  apply unfold_locales
  apply (simp_all add: icf_rec_unf hm_aux_correct hm_iteratei_impl)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "hm_ops  hm_basic.dflt_ops"

setup Locale_Code.open_block
interpretation hm: StdMapDefs hm_ops .
interpretation hm: StdMap hm_ops 
  unfolding hm_ops_def
  by (rule hm_basic.dflt_ops_impl)
interpretation hm: StdMap_no_invar hm_ops 
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "hm"

lemma pi_hm[proper_it]:
  shows "proper_it' hm_iteratei hm_iteratei"
  apply (rule proper_it'I)
  unfolding hm_iteratei_def HashMap_Impl.iteratei_alt_def 
  by (intro icf_proper_iteratorI)

interpretation pi_hm: proper_it_loc hm_iteratei hm_iteratei
  apply unfold_locales
  apply (rule pi_hm)
  done

text ‹Code generator test›

definition test_codegen where "test_codegen  (
  hm.add ,
  hm.add_dj ,
  hm.ball ,
  hm.bex ,
  hm.delete ,
  hm.empty ,
  hm.isEmpty ,
  hm.isSng ,
  hm.iterate ,
  hm.iteratei ,
  hm.list_it ,
  hm.lookup ,
  hm.restrict ,
  hm.sel ,
  hm.size ,
  hm.size_abort ,
  hm.sng ,
  hm.to_list ,
  hm.to_map ,
  hm.update ,
  hm.update_dj)"

export_code test_codegen checking SML


end

Theory Trie_Impl

(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section ‹\isaheader{Implementation of a trie with explicit invariants}›
theory Trie_Impl imports
  "../../Lib/Assoc_List"
  Trie.Trie
begin

subsection ‹Interuptible iterator›

fun iteratei_postfixed :: "'key list  ('key, 'val) trie  
    ('key list × 'val, ) set_iterator"
where
  "iteratei_postfixed ks (Trie vo ts) c f σ =
   (if c σ 
    then foldli ts c (λ(k, t) σ. iteratei_postfixed (k # ks) t c f σ)
           (case vo of None  σ | Some v  f (ks, v) σ) 
    else σ)"

definition iteratei :: "('key, 'val) trie  ('key list × 'val, ) set_iterator"
where "iteratei t c f σ = iteratei_postfixed [] t c f σ"

lemma iteratei_postfixed_interrupt:
  "¬ c σ  iteratei_postfixed ks t c f σ = σ"
by(cases t) simp

lemma iteratei_interrupt:
  "¬ c σ  iteratei t c f σ = σ"
unfolding iteratei_def by (simp add: iteratei_postfixed_interrupt)

lemma iteratei_postfixed_alt_def :
  "iteratei_postfixed ks ((Trie vo ts)::('key, 'val) trie) =
   (set_iterator_union 
     (case_option set_iterator_emp (λv. set_iterator_sng (ks, v)) vo) 
     (set_iterator_image snd
     (set_iterator_product (foldli ts) 
        (λ(k, t'). iteratei_postfixed (k # ks) t'))
     ))"
proof -
  have aux: "c f. (λ(k, t). iteratei_postfixed (k # ks) t c f) =
              (λa. iteratei_postfixed (fst a # ks) (snd a) c f)"
    by auto

  show ?thesis
    apply (rule ext)+ apply (rename_tac c f σ)
    apply (simp add: set_iterator_product_def set_iterator_image_filter_def
                     set_iterator_union_def set_iterator_sng_def set_iterator_image_alt_def
                     case_prod_beta set_iterator_emp_def 
            split: option.splits)
    apply (simp add: aux)
  done
qed

lemma iteratei_postfixed_correct :
  assumes invar: "invar_trie (t :: ('key, 'val) trie)"
  shows "set_iterator ((iteratei_postfixed ks0 t)::('key list × 'val, ) set_iterator)
           ((λksv. (rev (fst ksv) @ ks0, (snd ksv))) ` (map_to_set (lookup_trie t)))"
using invar
proof (induct t arbitrary: ks0)
  case (Trie vo kvs)
  note ind_hyp = Trie(1)
  note invar = Trie(2)

  from invar 
  have dist_fst_kvs : "distinct (map fst kvs)"
   and dist_kvs: "distinct kvs"
   and invar_child: "k t. (k, t)  set kvs  invar_trie t"
  by (simp_all add: Ball_def distinct_map)

  ― ‹root iterator›
  define it_vo :: "('key list × 'val, ) set_iterator"
    where "it_vo =
      (case vo of None  set_iterator_emp 
       | Some v  set_iterator_sng (ks0, v))"
  define vo_S where "vo_S = (case vo of None  {} | Some v  {(ks0, v)})"
  have it_vo_OK: "set_iterator it_vo vo_S"
    unfolding it_vo_def vo_S_def
    by (simp split: option.split 
             add: set_iterator_emp_correct set_iterator_sng_correct)

  ― ‹children iterator›
  define it_prod :: "(('key × ('key, 'val) trie) × 'key list × 'val, ) set_iterator"
    where "it_prod = set_iterator_product (foldli kvs) (λ(k, y). iteratei_postfixed (k # ks0) y)"

  define it_prod_S where "it_prod_S = (SIGMA kt:set kvs.
       (λksv. (rev (fst ksv) @ ((fst kt) # ks0), snd ksv)) `
       map_to_set (lookup_trie (snd kt)))"

  have it_prod_OK: "set_iterator it_prod it_prod_S"
  proof -
    from set_iterator_foldli_correct[OF dist_kvs]
    have it_foldli: "set_iterator (foldli kvs) (set kvs)" .

    { fix kt 
      assume kt_in: "kt  set kvs"
      hence k_t_in: "(fst kt, snd kt)  set kvs" by simp

      note ind_hyp [OF k_t_in, OF invar_child[OF k_t_in], of "fst kt # ks0"]
    } note it_child = this
       
    show ?thesis
      unfolding it_prod_def it_prod_S_def
      apply (rule set_iterator_product_correct [OF it_foldli])
      apply (insert it_child)
      apply (simp add: case_prod_beta)
    done
  qed

  have it_image_OK : "set_iterator (set_iterator_image snd it_prod) (snd ` it_prod_S)"
  proof (rule set_iterator_image_correct[OF it_prod_OK])
    from dist_fst_kvs
    have "k v1 v2. (k, v1)  set kvs  (k, v2)  set kvs  v1 = v2"
       by (induct kvs) (auto simp add: image_iff)
    thus "inj_on snd it_prod_S" 
      unfolding inj_on_def it_prod_S_def
      apply (simp add: image_iff Ball_def map_to_set_def)
      apply auto
    done
  qed auto

  ― ‹overall iterator›
  have it_all_OK: "set_iterator 
      ((iteratei_postfixed ks0 (Trie vo kvs)):: ('key list × 'val, ) set_iterator)
     (vo_S  snd ` it_prod_S)"
    unfolding iteratei_postfixed_alt_def 
       it_vo_def[symmetric]
       it_prod_def[symmetric]
  proof (rule set_iterator_union_correct [OF it_vo_OK it_image_OK])
    show "vo_S  snd ` it_prod_S = {}"
      unfolding vo_S_def it_prod_S_def
      by (simp split: option.split add: set_eq_iff image_iff)
  qed

  ― ‹rewrite result set›
  have it_set_rewr: "((λksv. (rev (fst ksv) @ ks0, snd ksv)) `
      map_to_set (lookup_trie (Trie vo kvs))) = (vo_S  snd ` it_prod_S)"
    (is "?ls = ?rs")
    apply (simp add: map_to_set_def lookup_eq_Some_iff[OF invar]
                     set_eq_iff image_iff vo_S_def it_prod_S_def Ball_def Bex_def)
    apply (simp split: option.split del: ex_simps add: ex_simps[symmetric])
    apply (intro allI impI iffI)
    apply auto[]
    apply (metis append_Cons append_Nil append_assoc rev.simps)
  done
    
  ― ‹done›
  show ?case
    unfolding it_set_rewr using it_all_OK by fast
qed

definition trie_reverse_key where
  "trie_reverse_key ksv = (rev (fst ksv), (snd ksv))"

lemma trie_reverse_key_alt_def[code] :
  "trie_reverse_key (ks, v) = (rev ks, v)"
unfolding trie_reverse_key_def by auto

lemma trie_reverse_key_reverse[simp] :
  "trie_reverse_key (trie_reverse_key ksv) = ksv"
by (simp add: trie_reverse_key_def)

lemma trie_iteratei_correct:
  assumes invar: "invar_trie (t :: ('key, 'val) trie)"
  shows "set_iterator ((iteratei t)::('key list × 'val, ) set_iterator)
           (trie_reverse_key ` (map_to_set (lookup_trie t)))"
unfolding trie_reverse_key_def[abs_def] iteratei_def[abs_def]
using iteratei_postfixed_correct [OF invar, of "[]"]
by simp

hide_const (open) iteratei
hide_type (open) trie

end

Theory Trie2

(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section ‹\isaheader{Tries without invariants}›
theory Trie2 imports
  Trie_Impl
begin

(*<*)
lemma rev_rev_image: "rev ` rev ` A = A"
by(auto intro: rev_image_eqI[where x="rev y" for y])
(*>*)

subsection ‹Abstract type definition›

typedef ('key, 'val) trie = 
  "{t :: ('key, 'val) Trie.trie. invar_trie t}"
  morphisms impl_of Trie
proof
  show "empty_trie  ?trie" by(simp)
qed

lemma invar_trie_impl_of [simp, intro]: "invar_trie (impl_of t)"
using impl_of[of t] by simp

lemma Trie_impl_of [code abstype]: "Trie (impl_of t) = t"
by(rule impl_of_inverse)

subsection ‹Primitive operations›

definition empty :: "('key, 'val) trie"
where "empty = Trie (empty_trie)"

definition update :: "'key list  'val  ('key, 'val) trie  ('key, 'val) trie"
where "update ks v t = Trie (update_trie ks v (impl_of t))"

definition delete :: "'key list  ('key, 'val) trie  ('key, 'val) trie"
where "delete ks t = Trie (delete_trie ks (impl_of t))"

definition lookup :: "('key, 'val) trie  'key list  'val option"
where "lookup t = lookup_trie (impl_of t)"

definition isEmpty :: "('key, 'val) trie  bool"
where "isEmpty t = is_empty_trie (impl_of t)"


definition iteratei :: "('key, 'val) trie  ('key list × 'val, ) set_iterator"
where "iteratei t = set_iterator_image trie_reverse_key (Trie_Impl.iteratei (impl_of t))"

lemma iteratei_code[code] :
  "iteratei t c f = Trie_Impl.iteratei (impl_of t) c (λ(ks, v). f (rev ks, v))"
unfolding iteratei_def set_iterator_image_alt_def 
apply (subgoal_tac "(λx. f (trie_reverse_key x)) = (λ(ks, v). f (rev ks, v))")
apply (auto simp add: trie_reverse_key_def)
done

lemma impl_of_empty [code abstract]: "impl_of empty = empty_trie"
by(simp add: empty_def Trie_inverse)

lemma impl_of_update [code abstract]: "impl_of (update ks v t) = update_trie ks v (impl_of t)"
by(simp add: update_def Trie_inverse invar_trie_update)

lemma impl_of_delete [code abstract]: "impl_of (delete ks t) = delete_trie ks (impl_of t)"
by(simp add: delete_def Trie_inverse invar_trie_delete)

subsection ‹Correctness of primitive operations›

lemma lookup_empty [simp]: "lookup empty = Map.empty"
by(simp add: lookup_def empty_def Trie_inverse)

lemma lookup_update [simp]: "lookup (update ks v t) = (lookup t)(ks  v)"
by(simp add: lookup_def update_def Trie_inverse invar_trie_update lookup_update')

lemma lookup_delete [simp]: "lookup (delete ks t) = (lookup t)(ks := None)"
by(simp add: lookup_def delete_def Trie_inverse invar_trie_delete lookup_delete')

lemma isEmpty_lookup: "isEmpty t  lookup t = Map.empty"
by(simp add: isEmpty_def lookup_def is_empty_lookup_empty)

lemma finite_dom_lookup: "finite (dom (lookup t))"
by(simp add: lookup_def finite_dom_lookup)

lemma iteratei_correct:
  "map_iterator (iteratei m) (lookup m)"
proof -
  note it_base = Trie_Impl.trie_iteratei_correct [of "impl_of m"]
  show ?thesis
    unfolding iteratei_def lookup_def
    apply (rule set_iterator_image_correct [OF it_base])
    apply (simp_all add: set_eq_iff image_iff inj_on_def)
  done
qed

subsection ‹Type classes›

instantiation trie :: (equal, equal) equal begin

definition "equal_class.equal (t :: ('a, 'b) trie) t' = (impl_of t = impl_of t')"

instance
proof
qed(simp add: equal_trie_def impl_of_inject)
end

hide_const (open) empty lookup update delete iteratei isEmpty

end

Theory TrieMapImpl

(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section ‹\isaheader{Map implementation via tries}›
theory TrieMapImpl imports
  Trie2
  "../gen_algo/MapGA"
begin
(*@impl Map
  @type ('k,'v) tm
  @abbrv tm,t
  Maps over keys of type @{typ "'k list"} implemented by tries.
*)

subsection ‹Operations›

type_synonym ('k, 'v) tm = "('k, 'v) trie"

definition [icf_rec_def]: "tm_basic_ops  
  bmap_op_α = Trie2.lookup,
  bmap_op_invar = λ_. True,
  bmap_op_empty = (λ_::unit. Trie2.empty),
  bmap_op_lookup = (λk m. Trie2.lookup m k),
  bmap_op_update = Trie2.update,
  bmap_op_update_dj = Trie2.update,
  bmap_op_delete = Trie2.delete,
  bmap_op_list_it = Trie2.iteratei
"


setup Locale_Code.open_block
interpretation tm_basic: StdBasicMap tm_basic_ops
  apply unfold_locales
  apply (simp_all 
      add: icf_rec_unf Trie2.finite_dom_lookup Trie2.iteratei_correct 
      add: map_upd_eq_restrict)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "tm_ops  tm_basic.dflt_ops"

setup Locale_Code.open_block
interpretation tm: StdMap tm_ops 
  unfolding tm_ops_def
  by (rule tm_basic.dflt_ops_impl)
interpretation tm: StdMap_no_invar tm_ops 
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "tm"

lemma pi_trie_impl[proper_it]: 
  shows "proper_it'
    ((Trie_Impl.iteratei) :: _  (_,'σa) set_iterator)
    ((Trie_Impl.iteratei) :: _  (_,'σb) set_iterator)"
  unfolding Trie_Impl.iteratei_def[abs_def]
proof (rule proper_it'I)
  (*note [[show_types, show_consts]]*)
  fix t :: "('k,'v) Trie.trie"
  {
    fix l and t :: "('k,'v) Trie.trie"
    have "proper_it ((Trie_Impl.iteratei_postfixed l t)
       :: (_,'σa) set_iterator)
      ((Trie_Impl.iteratei_postfixed l t)
       :: (_,'σb) set_iterator)"
    proof (induct t arbitrary: l)
      case (Trie vo kvs l)

      let ?ITA = "λl t. (Trie_Impl.iteratei_postfixed l t)
        :: (_,'σa) set_iterator"
      let ?ITB = "λl t. (Trie_Impl.iteratei_postfixed l t)
        :: (_,'σb) set_iterator"

      show ?case
        unfolding Trie_Impl.iteratei_postfixed_alt_def
        apply (rule pi_union)
        apply (auto split: option.split intro: icf_proper_iteratorI) []
      proof (rule pi_image)
        define bs where "bs = (λ(k,t). SOME l'::('k list × 'v) list. 
          ?ITA (k#l) t = foldli l'  ?ITB (k#l) t = foldli l')"

        have EQ1: "(k,t)set kvs. ?ITA (k#l) t = foldli (bs (k,t))" and
          EQ2: "(k,t)set kvs. ?ITB (k#l) t = foldli (bs (k,t))"
        proof (safe)
          fix k t
          assume A: "(k,t)  set kvs"
          from Trie.hyps[OF A, of "k#l"] have 
            PI: "proper_it (?ITA (k#l) t) (?ITB (k#l) t)" 
            by assumption
          obtain l' where 
            "?ITA (k#l) t = foldli l'
           (?ITB (k#l) t) = foldli l'"
            by (blast intro: proper_itE[OF PI])
          thus "?ITA (k#l) t = foldli (bs (k,t))"
            "?ITB (k#l) t = foldli (bs (k,t))"
            unfolding bs_def
            apply auto
            apply (metis (lifting, full_types) someI_ex) 
            apply (metis (lifting, full_types) someI_ex) 
            done
        qed

        have PEQ1: "set_iterator_product (foldli kvs) (λ(k,t). ?ITA (k#l) t) 
          = set_iterator_product (foldli kvs) (λkt. foldli (bs kt))"
          apply (rule set_iterator_product_eq2)
          using EQ1 by auto
        have PEQ2: "set_iterator_product (foldli kvs) (λ(k,t). ?ITB (k#l) t)
          = set_iterator_product (foldli kvs) (λkt. foldli (bs kt))"
          apply (rule set_iterator_product_eq2)
          using EQ2 by auto
        show "proper_it
          (set_iterator_product (foldli kvs) (λ(k,t). ?ITA (k#l) t))
          (set_iterator_product (foldli kvs) (λ(k,t). ?ITB (k#l) t))"
          apply (subst PEQ1)
          apply (subst PEQ2)
          apply (auto simp: set_iterator_product_foldli_conv)
          by (blast intro: proper_itI)
      qed
    qed
  } thus "proper_it
      (iteratei_postfixed [] t :: (_,'σa) set_iterator) 
      (iteratei_postfixed [] t :: (_,'σb) set_iterator)" .
qed

lemma pi_trie[proper_it]: 
  "proper_it' Trie2.iteratei Trie2.iteratei"
  unfolding Trie2.iteratei_def[abs_def]
  apply (rule proper_it'I)
  apply (intro icf_proper_iteratorI)
  apply (rule proper_it'D)
  by (rule pi_trie_impl)

interpretation pi_trie: proper_it_loc Trie2.iteratei Trie2.iteratei
  apply unfold_locales
  apply (rule pi_trie)
  done

text ‹Code generator test›
definition "test_codegen  (
  tm.add ,
  tm.add_dj ,
  tm.ball ,
  tm.bex ,
  tm.delete ,
  tm.empty ,
  tm.isEmpty ,
  tm.isSng ,
  tm.iterate ,
  tm.iteratei ,
  tm.list_it ,
  tm.lookup ,
  tm.restrict ,
  tm.sel ,
  tm.size ,
  tm.size_abort ,
  tm.sng ,
  tm.to_list ,
  tm.to_map ,
  tm.update ,
  tm.update_dj)"

export_code test_codegen checking SML

end

Theory ArrayHashMap_Impl

(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section ‹\isaheader{Array-based hash map implementation}›
theory ArrayHashMap_Impl imports 
  "../../Lib/HashCode"
  "../../Lib/Code_Target_ICF"
  "../../Lib/Diff_Array"
  "../gen_algo/ListGA"
  ListMapImpl
  "../../Iterator/Array_Iterator"
begin

text ‹Misc.›

setup Locale_Code.open_block
interpretation a_idx_it: 
  idx_iteratei_loc list_of_array "λ_. True" array_length array_get
  apply unfold_locales
  apply (case_tac [!] s) [2]
  apply auto
  done
setup Locale_Code.close_block

(*
lemma idx_iteratei_aux_array_get_Array_conv_nth:
  "idx_iteratei_aux array_get sz i (Array xs) c f σ = idx_iteratei_aux (!) sz i xs c f σ"
apply(induct get≡"(!) :: 'b list ⇒ nat ⇒ 'b" sz i xs c f σ rule: idx_iteratei_aux.induct)
apply(subst (1 2) idx_iteratei_aux.simps)
apply simp
done

lemma idx_iteratei_array_get_Array_conv_nth:
  "idx_iteratei array_get array_length (Array xs) = idx_iteratei nth length xs"
by(simp add: idx_iteratei_def fun_eq_iff idx_iteratei_aux_array_get_Array_conv_nth)

lemma idx_iteratei_aux_nth_conv_foldli_drop:
  fixes xs :: "'b list"
  assumes "i ≤ length xs"
  shows "idx_iteratei_aux (!) (length xs) i xs c f σ = foldli (drop (length xs - i) xs) c f σ"
using assms
proof(induct get≡"(!) :: 'b list ⇒ nat ⇒ 'b" sz≡"length xs" i xs c f σ rule: idx_iteratei_aux.induct)
  case (1 i l c f σ)
  show ?case
  proof(cases "i = 0 ∨ ¬ c σ")
    case True thus ?thesis
      by(subst idx_iteratei_aux.simps)(auto)
  next
    case False
    hence i: "i > 0" and c: "c σ" by auto
    hence "idx_iteratei_aux (!) (length l) i l c f σ = idx_iteratei_aux (!) (length l) (i - 1) l c f (f (l ! (length l - i)) σ)"
      by(subst idx_iteratei_aux.simps) simp
    also have "… = foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) σ)"
      using `i ≤ length l` i c by -(rule 1, auto)
    also from `i ≤ length l` i
    have "drop (length l - i) l = (l ! (length l - i)) # drop (length l - (i - 1)) l"
      by(subst Cons_nth_drop_Suc[symmetric])(simp_all, metis Suc_eq_plus1_left add_diff_assoc)
    hence "foldli (drop (length l - (i - 1)) l) c f (f (l ! (length l - i)) σ) = foldli (drop (length l - i) l) c f σ"
      using c by simp
    finally show ?thesis .
  qed
qed

lemma idx_iteratei_nth_length_conv_foldli: "idx_iteratei nth length = foldli"
by(rule ext)+(simp add: idx_iteratei_def idx_iteratei_aux_nth_conv_foldli_drop)
*)

subsection ‹Type definition and primitive operations›

definition load_factor :: nat ― ‹in percent›
  where "load_factor = 75"

text ‹
  We do not use @{typ "('k, 'v) assoc_list"} for the buckets but plain lists of key-value pairs.
  This speeds up rehashing because we then do not have to go through the abstract operations.
›

datatype ('key, 'val) hashmap =
  HashMap "('key × 'val) list array" "nat"

subsection ‹Operations›

definition new_hashmap_with :: "nat  ('key :: hashable, 'val) hashmap"
where "size. new_hashmap_with size = HashMap (new_array [] size) 0"

definition ahm_empty :: "unit  ('key :: hashable, 'val) hashmap"
where "ahm_empty  λ_. new_hashmap_with (def_hashmap_size TYPE('key))"

definition bucket_ok :: "nat  nat  (('key :: hashable) × 'val) list  bool"
where "bucket_ok len h kvs = (k  fst ` set kvs. bounded_hashcode_nat len k = h)"

definition ahm_invar_aux :: "nat  (('key :: hashable) × 'val) list array  bool"
where
  "ahm_invar_aux n a 
  (h. h < array_length a  bucket_ok (array_length a) h (array_get a h)  distinct (map fst (array_get a h))) 
  array_foldl (λ_ n kvs. n + size kvs) 0 a = n 
  array_length a > 1"


primrec ahm_invar :: "('key :: hashable, 'val) hashmap  bool"
where "ahm_invar (HashMap a n) = ahm_invar_aux n a"

definition ahm_α_aux :: "(('key :: hashable) × 'val) list array  'key  'val option"
where [simp]: "ahm_α_aux a k = map_of (array_get a (bounded_hashcode_nat (array_length a) k)) k"

primrec ahm_α :: "('key :: hashable, 'val) hashmap  'key  'val option"
where
  "ahm_α (HashMap a _) = ahm_α_aux a"

definition ahm_lookup :: "'key  ('key :: hashable, 'val) hashmap  'val option"
where "ahm_lookup k hm  = ahm_α hm k"

primrec ahm_iteratei_aux :: "((('key :: hashable) × 'val) list array)  ('key × 'val, ) set_iterator"
where "ahm_iteratei_aux (Array xs) c f = foldli (concat xs) c f"

primrec ahm_iteratei :: "(('key :: hashable, 'val) hashmap)  (('key × 'val), ) set_iterator"
where
  "ahm_iteratei (HashMap a n) = ahm_iteratei_aux a"

definition ahm_rehash_aux' :: "nat  'key × 'val  (('key :: hashable) × 'val) list array  ('key × 'val) list array"
where
  "ahm_rehash_aux' n kv a =
   (let h = bounded_hashcode_nat n (fst kv)
    in array_set a h (kv # array_get a h))"

definition ahm_rehash_aux :: "(('key :: hashable) × 'val) list array  nat  ('key × 'val) list array"
where
  "ahm_rehash_aux a sz = ahm_iteratei_aux a (λx. True) (ahm_rehash_aux' sz) (new_array [] sz)"

primrec ahm_rehash :: "('key :: hashable, 'val) hashmap  nat  ('key, 'val) hashmap"
where "ahm_rehash (HashMap a n) sz = HashMap (ahm_rehash_aux a sz) n"

primrec hm_grow :: "('key :: hashable, 'val) hashmap  nat"
where "hm_grow (HashMap a n) = 2 * array_length a + 3"

primrec ahm_filled :: "('key :: hashable, 'val) hashmap  bool"
where "ahm_filled (HashMap a n) = (array_length a * load_factor  n * 100)"

primrec ahm_update_aux :: "('key :: hashable, 'val) hashmap  'key  'val  ('key, 'val) hashmap"
where
  "ahm_update_aux (HashMap a n) k v = 
  (let h = bounded_hashcode_nat (array_length a) k;
       m = array_get a h;
       insert = map_of m k = None
   in HashMap (array_set a h (AList.update k v m)) (if insert then n + 1 else n))"

definition ahm_update :: "'key  'val  ('key :: hashable, 'val) hashmap  ('key, 'val) hashmap"
where
  "ahm_update k v hm = 
   (let hm' = ahm_update_aux hm k v
    in (if ahm_filled hm' then ahm_rehash hm' (hm_grow hm') else hm'))"

primrec ahm_delete :: "'key  ('key :: hashable, 'val) hashmap  ('key, 'val) hashmap"
where
  "ahm_delete k (HashMap a n) =
  (let h = bounded_hashcode_nat (array_length a) k;
       m = array_get a h;
       deleted = (map_of m k  None)
   in HashMap (array_set a h (AList.delete k m)) (if deleted then n - 1 else n))"


lemma hm_grow_gt_1 [iff]:
  "Suc 0 < hm_grow hm"
by(cases hm)(simp)

lemma bucket_ok_Nil [simp]: "bucket_ok len h [] = True"
by(simp add: bucket_ok_def)

lemma bucket_okD:
  " bucket_ok len h xs; (k, v)  set xs 
   bounded_hashcode_nat len k = h"
by(auto simp add: bucket_ok_def)

lemma bucket_okI:
  "(k. k  fst ` set kvs  bounded_hashcode_nat len k = h)  bucket_ok len h kvs"
by(simp add: bucket_ok_def)


subsection @{term ahm_invar}

lemma ahm_invar_auxE:
  assumes "ahm_invar_aux n a"
  obtains "h. h < array_length a  bucket_ok (array_length a) h (array_get a h)  distinct (map fst (array_get a h))"
  and "n = array_foldl (λ_ n kvs. n + length kvs) 0 a" and "array_length a > 1"
using assms unfolding ahm_invar_aux_def by blast

lemma ahm_invar_auxI:
  " h. h < array_length a  bucket_ok (array_length a) h (array_get a h);
     h. h < array_length a  distinct (map fst (array_get a h));
     n = array_foldl (λ_ n kvs. n + length kvs) 0 a; array_length a > 1 
   ahm_invar_aux n a"
unfolding ahm_invar_aux_def by blast

lemma ahm_invar_distinct_fst_concatD:
  assumes inv: "ahm_invar_aux n (Array xs)"
  shows "distinct (map fst (concat xs))"
proof -
  { fix h
    assume "h < length xs"
    with inv have "bucket_ok (length xs) h (xs ! h)" "distinct (map fst (xs ! h))"
      by(simp_all add: ahm_invar_aux_def) }
  note no_junk = this

  show ?thesis unfolding map_concat
  proof(rule distinct_concat')
    have "distinct [xxs . x  []]" unfolding distinct_conv_nth
    proof(intro allI ballI impI)
      fix i j
      assume "i < length [xxs . x  []]" "j < length [xxs . x  []]" "i  j"
      from filter_nth_ex_nth[OF i < length [xxs . x  []]]
      obtain i' where "i'  i" "i' < length xs" and ith: "[xxs . x  []] ! i = xs ! i'" 
        and eqi: "[xtake i' xs . x  []] = take i [xxs . x  []]" by blast
      from filter_nth_ex_nth[OF j < length [xxs . x  []]]
      obtain j' where "j'  j" "j' < length xs" and jth: "[xxs . x  []] ! j = xs ! j'"
        and eqj: "[xtake j' xs . x  []] = take j [xxs . x  []]" by blast
      show "[xxs . x  []] ! i  [xxs . x  []] ! j"
      proof
        assume "[xxs . x  []] ! i = [xxs . x  []] ! j"
        hence eq: "xs ! i' = xs ! j'" using ith jth by simp
        from i < length [xxs . x  []]
        have "[xxs . x  []] ! i  set [xxs . x  []]" by(rule nth_mem)
        with ith have "xs ! i'  []" by simp
        then obtain kv where "kv  set (xs ! i')" by(fastforce simp add: neq_Nil_conv)
        with no_junk[OF i' < length xs] have "bounded_hashcode_nat (length xs) (fst kv) = i'"
          by(simp add: bucket_ok_def)
        moreover from eq kv  set (xs ! i') have "kv  set (xs ! j')" by simp
        with no_junk[OF j' < length xs] have "bounded_hashcode_nat (length xs) (fst kv) = j'"
          by(simp add: bucket_ok_def)
        ultimately have [simp]: "i' = j'" by simp
        from i < length [xxs . x  []] have "i = length (take i [xxs . x  []])" by simp
        also from eqi eqj have "take i [xxs . x  []] = take j [xxs . x  []]" by simp
        finally show False using i  j j < length [xxs . x  []] by simp
      qed
    qed
    moreover have "inj_on (map fst) {x  set xs. x  []}"
    proof(rule inj_onI)
      fix x y
      assume "x  {x  set xs. x  []}" "y  {x  set xs. x  []}" "map fst x = map fst y"
      hence "x  set xs" "y  set xs" "x  []" "y  []" by auto
      from x  set xs obtain i where "xs ! i = x" "i < length xs" unfolding set_conv_nth by fastforce
      from y  set xs obtain j where "xs ! j = y" "j < length xs" unfolding set_conv_nth by fastforce
      from x  [] obtain k v x' where "x = (k, v) # x'" by(cases x) auto
      with no_junk[OF i < length xs] xs ! i = x
      have "bounded_hashcode_nat (length xs) k = i" by(auto simp add: bucket_ok_def)
      moreover from ‹map fst x = map fst y x = (k, v) # x' obtain v' where "(k, v')  set y" by fastforce
      with no_junk[OF j < length xs] xs ! j = y
      have "bounded_hashcode_nat (length xs) k = j" by(auto simp add: bucket_ok_def)
      ultimately have "i = j" by simp
      with xs ! i = x xs ! j = y show "x = y" by simp
    qed
    ultimately show "distinct [ysmap (map fst) xs . ys  []]"
      by(simp add: filter_map o_def distinct_map)
  next
    fix ys
    assume "ys  set (map (map fst) xs)"
    thus "distinct ys" by(clarsimp simp add: set_conv_nth)(rule no_junk)
  next
    fix ys zs
    assume "ys  set (map (map fst) xs)" "zs  set (map (map fst) xs)" "ys  zs"
    then obtain ys' zs' where [simp]: "ys = map fst ys'" "zs = map fst zs'" 
      and "ys'  set xs" "zs'  set xs" by auto
    have "fst ` set ys'  fst ` set zs' = {}"
    proof(rule equals0I)
      fix k
      assume "k  fst ` set ys'  fst ` set zs'"
      then obtain v v' where "(k, v)  set ys'" "(k, v')  set zs'" by(auto)
      from ys'  set xs obtain i where "xs ! i = ys'" "i < length xs" unfolding set_conv_nth by fastforce
      with (k, v)  set ys' have "bounded_hashcode_nat (length xs) k = i" by(auto dest: no_junk bucket_okD)
      moreover
      from zs'  set xs obtain j where "xs ! j = zs'" "j < length xs" unfolding set_conv_nth by fastforce
      with (k, v')  set zs' have "bounded_hashcode_nat (length xs) k = j" by(auto dest: no_junk bucket_okD)
      ultimately have "i = j" by simp
      with xs ! i = ys' xs ! j = zs' have "ys' = zs'" by simp
      with ys  zs show False by simp
    qed
    thus "set ys  set zs = {}" by simp
  qed
qed

subsection @{term "ahm_α"}

lemma finite_dom_ahm_α_aux:
  assumes "ahm_invar_aux n a"
  shows "finite (dom (ahm_α_aux a))"
proof -
  have "dom (ahm_α_aux a)  (h  range (bounded_hashcode_nat (array_length a) :: 'a  nat). dom (map_of (array_get a h)))"
    by(force simp add: dom_map_of_conv_image_fst ahm_α_aux_def dest: map_of_SomeD)
  moreover have "finite "
  proof(rule finite_UN_I)
    from ‹ahm_invar_aux n a have "array_length a > 1" by(simp add: ahm_invar_aux_def)
    hence "range (bounded_hashcode_nat (array_length a) :: 'a  nat)  {0..<array_length a}"
      by(auto simp add: bounded_hashcode_nat_bounds)
    thus "finite (range (bounded_hashcode_nat (array_length a) :: 'a  nat))"
      by(rule finite_subset) simp
  qed(rule finite_dom_map_of)
  ultimately show ?thesis by(rule finite_subset)
qed

lemma ahm_α_aux_conv_map_of_concat:
  assumes inv: "ahm_invar_aux n (Array xs)"
  shows "ahm_α_aux (Array xs) = map_of (concat xs)"
proof
  fix k
  show "ahm_α_aux (Array xs) k = map_of (concat xs) k"
  proof(cases "map_of (concat xs) k")
    case None
    hence "k  fst ` set (concat xs)" by(simp add: map_of_eq_None_iff)
    hence "k  fst ` set (xs ! bounded_hashcode_nat (length xs) k)"
    proof(rule contrapos_nn)
      assume "k  fst ` set (xs ! bounded_hashcode_nat (length xs) k)"
      then obtain v where "(k, v)  set (xs ! bounded_hashcode_nat (length xs) k)" by auto
      moreover from inv have "bounded_hashcode_nat (length xs) k < length xs"
        by(simp add: bounded_hashcode_nat_bounds ahm_invar_aux_def)
      ultimately show "k  fst ` set (concat xs)"
        by(force intro: rev_image_eqI)
    qed
    thus ?thesis unfolding None by(simp add: map_of_eq_None_iff)
  next
    case (Some v)
    hence "(k, v)  set (concat xs)" by(rule map_of_SomeD)
    then obtain ys where "ys  set xs" "(k, v)  set ys"
      unfolding set_concat by blast
    from ys  set xs obtain i j where "i < length xs" "xs ! i = ys"
      unfolding set_conv_nth by auto
    with inv (k, v)  set ys
    show ?thesis unfolding Some
      by(force dest: bucket_okD simp add: ahm_invar_aux_def)
  qed
qed

lemma ahm_invar_aux_card_dom_ahm_α_auxD:
  assumes inv: "ahm_invar_aux n a"
  shows "card (dom (ahm_α_aux a)) = n"
proof(cases a)
  case [simp]: (Array xs)
  from inv have "card (dom (ahm_α_aux (Array xs))) = card (dom (map_of (concat xs)))"
    by(simp add: ahm_α_aux_conv_map_of_concat)
  also from inv have "distinct (map fst (concat xs))"
    by(simp add: ahm_invar_distinct_fst_concatD)
  hence "card (dom (map_of (concat xs))) = length (concat xs)"
    by(rule card_dom_map_of)
  also have "length (concat xs) = foldl (+) 0 (map length xs)"
    by (simp add: length_concat foldl_conv_fold add.commute fold_plus_sum_list_rev)
  also from inv
  have " = n" unfolding foldl_map by(simp add: ahm_invar_aux_def array_foldl_foldl)
  finally show ?thesis by(simp)
qed

lemma finite_dom_ahm_α:
  "ahm_invar hm  finite (dom (ahm_α hm))"
by(cases hm)(auto intro: finite_dom_ahm_α_aux)

lemma finite_map_ahm_α_aux:
  "finite_map ahm_α_aux (ahm_invar_aux n)"
by(unfold_locales)(rule finite_dom_ahm_α_aux)

lemma finite_map_ahm_α:
  "finite_map ahm_α ahm_invar"
by(unfold_locales)(rule finite_dom_ahm_α)

subsection @{term ahm_empty}

lemma ahm_invar_aux_new_array:
  assumes "n > 1"
  shows "ahm_invar_aux 0 (new_array [] n)"
proof -
  have "foldl (λb (k, v). b + length v) 0 (zip [0..<n] (replicate n [])) = 0"
    by(induct n)(simp_all add: replicate_Suc_conv_snoc del: replicate_Suc)
  with assms show ?thesis by(simp add: ahm_invar_aux_def array_foldl_new_array)
qed

lemma ahm_invar_new_hashmap_with:
  "n > 1  ahm_invar (new_hashmap_with n)"
by(auto simp add: ahm_invar_def new_hashmap_with_def intro: ahm_invar_aux_new_array)

lemma ahm_α_new_hashmap_with:
  "n > 1  ahm_α (new_hashmap_with n) = Map.empty"
by(simp add: new_hashmap_with_def bounded_hashcode_nat_bounds fun_eq_iff)

lemma ahm_invar_ahm_empty [simp]: "ahm_invar (ahm_empty ())"
using def_hashmap_size[where ?'a = 'a]
by(auto intro: ahm_invar_new_hashmap_with simp add: ahm_empty_def)

lemma ahm_empty_correct [simp]: "ahm_α (ahm_empty ()) = Map.empty"
using def_hashmap_size[where ?'a = 'a]
by(auto intro: ahm_α_new_hashmap_with simp add: ahm_empty_def)

lemma ahm_empty_impl: "map_empty ahm_α ahm_invar ahm_empty"
by(unfold_locales)(auto)

subsection @{term "ahm_lookup"}

lemma ahm_lookup_impl: "map_lookup ahm_α ahm_invar ahm_lookup"
by(unfold_locales)(simp add: ahm_lookup_def)

subsection @{term "ahm_iteratei"}

lemma ahm_iteratei_aux_impl:
  assumes invar_m: "ahm_invar_aux n m"
  shows "map_iterator (ahm_iteratei_aux m) (ahm_α_aux m)"
proof -
  obtain ms where m_eq[simp]: "m = Array ms" by (cases m)

  from ahm_invar_distinct_fst_concatD[of n ms] invar_m
  have dist: "distinct (map fst (concat ms))" by simp

  show "map_iterator (ahm_iteratei_aux m) (ahm_α_aux m)" 
    using  set_iterator_foldli_correct[of "concat ms"] dist
    by (simp add: ahm_α_aux_conv_map_of_concat[OF invar_m[unfolded m_eq]]
                  ahm_iteratei_aux_def map_to_set_map_of[OF dist] distinct_map)
qed 

lemma ahm_iteratei_correct:
  assumes invar_hm: "ahm_invar hm"
  shows "map_iterator (ahm_iteratei hm) (ahm_α hm)"
proof -
  obtain A n where hm_eq [simp]: "hm = HashMap A n" by(cases hm)

  from ahm_iteratei_aux_impl[of n A] invar_hm
    show map_it: "map_iterator (ahm_iteratei hm) (ahm_α hm)" by simp 
qed

lemma ahm_iteratei_aux_code [code]:
  "ahm_iteratei_aux a c f σ = a_idx_it.idx_iteratei a c (λx. foldli x c f) σ"
proof(cases a)
  case [simp]: (Array xs)

  have "ahm_iteratei_aux a c f σ = foldli (concat xs) c f σ" by simp
  also have " = foldli xs c (λx. foldli x c f) σ" by (simp add: foldli_concat)
  thm a_idx_it.idx_iteratei_correct
  also have " = a_idx_it.idx_iteratei a c (λx. foldli x c f) σ"
    by (simp add: a_idx_it.idx_iteratei_correct)
  finally show ?thesis .
qed
subsection @{term "ahm_rehash"}

lemma array_length_ahm_rehash_aux':
  "array_length (ahm_rehash_aux' n kv a) = array_length a"
by(simp add: ahm_rehash_aux'_def Let_def)

lemma ahm_rehash_aux'_preserves_ahm_invar_aux:
  assumes inv: "ahm_invar_aux n a"
  and fresh: "k  fst ` set (array_get a (bounded_hashcode_nat (array_length a) k))"
  shows "ahm_invar_aux (Suc n) (ahm_rehash_aux' (array_length a) (k, v) a)"
  (is "ahm_invar_aux _ ?a")
proof(rule ahm_invar_auxI)
  fix h
  assume "h < array_length ?a"
  hence hlen: "h < array_length a" by(simp add: array_length_ahm_rehash_aux')
  with inv have bucket: "bucket_ok (array_length a) h (array_get a h)"
    and dist: "distinct (map fst (array_get a h))"
    by(auto elim: ahm_invar_auxE)
  let ?h = "bounded_hashcode_nat (array_length a) k"
  from hlen bucket show "bucket_ok (array_length ?a) h (array_get ?a h)"
    by(cases "h = ?h")(auto simp add: ahm_rehash_aux'_def Let_def array_length_ahm_rehash_aux' array_get_array_set_other dest: bucket_okD intro!: bucket_okI)
  from dist hlen fresh
  show "distinct (map fst (array_get ?a h))"
    by(cases "h = ?h")(auto simp add: ahm_rehash_aux'_def Let_def array_get_array_set_other)
next
  let ?f = "λn kvs. n + length kvs"
  { fix n :: nat and xs :: "('a × 'b) list list"
    have "foldl ?f n xs = n + foldl ?f 0 xs"
      by(induct xs arbitrary:  rule: rev_induct) simp_all }
  note fold = this
  let ?h = "bounded_hashcode_nat (array_length a) k"

  obtain xs where a [simp]: "a = Array xs" by(cases a)
  from inv have [simp]: "bounded_hashcode_nat (length xs) k < length xs"
    by(simp add: ahm_invar_aux_def bounded_hashcode_nat_bounds)
  have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
  from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
    by(auto elim: ahm_invar_auxE)
  hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
    by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
  thus "Suc n = array_foldl (λ_ n kvs. n + length kvs) 0 ?a"
    by(simp add: ahm_rehash_aux'_def Let_def array_foldl_foldl foldl_list_update)(subst (1 2 3 4) fold, simp)
next
  from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
  thus "1 < array_length ?a" by(simp add: array_length_ahm_rehash_aux')
qed

declare [[coercion_enabled = false]]

lemma ahm_rehash_aux_correct:
  fixes a :: "(('key :: hashable) × 'val) list array"
  assumes inv: "ahm_invar_aux n a"
  and "sz > 1"
  shows "ahm_invar_aux n (ahm_rehash_aux a sz)" (is "?thesis1")
  and "ahm_α_aux (ahm_rehash_aux a sz) = ahm_α_aux a" (is "?thesis2")
proof -
  (*interpret ahm: map_iterator "ahm_α_aux" "ahm_invar_aux n" "ahm_iteratei_aux"
    by(rule ahm_iteratei_aux_impl)*)
  let ?a = "ahm_rehash_aux a sz"
  let ?I = "λit a'. ahm_invar_aux (n - card it) a'  array_length a' = sz  (k. if k  it then ahm_α_aux a' k = None else ahm_α_aux a' k = ahm_α_aux a k)"
  have "?I {} ?a  (itdom (ahm_α_aux a). it  {}  ¬ True  ?I it ?a)"
    unfolding ahm_rehash_aux_def

  proof (rule map_iterator_rule_P[OF ahm_iteratei_aux_impl[OF inv], where
      c = "λ_. True" and f="ahm_rehash_aux' sz" and ?σ0.0 = "new_array [] sz"
      and I="?I"]
    )

    from inv have "card (dom (ahm_α_aux a)) = n" by(rule ahm_invar_aux_card_dom_ahm_α_auxD)
    moreover from 1 < sz have "ahm_invar_aux 0 (new_array ([] :: ('key × 'val) list) sz)"
      by(rule ahm_invar_aux_new_array)
    moreover {
      fix k
      assume "k  dom (ahm_α_aux a)"
      hence "ahm_α_aux a k = None" by auto
      moreover have "bounded_hashcode_nat sz k < sz" using 1 < sz
        by(simp add: bounded_hashcode_nat_bounds)
      ultimately have "ahm_α_aux (new_array [] sz) k = ahm_α_aux a k" by simp }
    ultimately show "?I (dom (ahm_α_aux a)) (new_array [] sz)"
      by(auto simp add: bounded_hashcode_nat_bounds[OF 1 < sz])
  next
    fix k :: 'key
      and v :: 'val
      and it a'
    assume "k  it" "ahm_α_aux a k = Some v" 
      and it_sub: "it  dom (ahm_α_aux a)"
      and I: "?I it a'"
    from I have inv': "ahm_invar_aux (n - card it) a'" 
      and a'_eq_a: "k. k  it  ahm_α_aux a' k = ahm_α_aux a k" 
      and a'_None: "k. k  it  ahm_α_aux a' k = None"
      and [simp]: "sz = array_length a'" by(auto split: if_split_asm)
    from it_sub finite_dom_ahm_α_aux[OF inv] have "finite it" by(rule finite_subset)
    moreover with k  it have "card it > 0" by(auto simp add: card_gt_0_iff)
    moreover from finite_dom_ahm_α_aux[OF inv] it_sub
    have "card it  card (dom (ahm_α_aux a))" by(rule card_mono)
    moreover have " = n" using inv
      by(simp add: ahm_invar_aux_card_dom_ahm_α_auxD)
    ultimately have "n - card (it - {k}) = (n - card it) + 1" using k  it by auto
    moreover from k  it have "ahm_α_aux a' k = None" by(rule a'_None)
    hence "k  fst ` set (array_get a' (bounded_hashcode_nat (array_length a') k))"
      by(simp add: map_of_eq_None_iff)
    ultimately have "ahm_invar_aux (n - card (it - {k})) (ahm_rehash_aux' sz (k, v) a')"
      using inv' by(auto intro: ahm_rehash_aux'_preserves_ahm_invar_aux)
    moreover have "array_length (ahm_rehash_aux' sz (k, v) a') = sz"
      by(simp add: array_length_ahm_rehash_aux')
    moreover {
      fix k'
      assume "k'  it - {k}"
      with bounded_hashcode_nat_bounds[OF 1 < sz, of k'] a'_None[of k']
      have "ahm_α_aux (ahm_rehash_aux' sz (k, v) a') k' = None"
        by(cases "bounded_hashcode_nat sz k = bounded_hashcode_nat sz k'")(auto simp add: array_get_array_set_other ahm_rehash_aux'_def Let_def)
    } moreover {
      fix k'
      assume "k'  it - {k}"
      with bounded_hashcode_nat_bounds[OF 1 < sz, of k'] bounded_hashcode_nat_bounds[OF 1 < sz, of k] a'_eq_a[of k'] k  it
      have "ahm_α_aux (ahm_rehash_aux' sz (k, v) a') k' = ahm_α_aux a k'"
        unfolding ahm_rehash_aux'_def Let_def using ‹ahm_α_aux a k = Some v
        by(cases "bounded_hashcode_nat sz k = bounded_hashcode_nat sz k'")(case_tac [!] "k' = k", simp_all add: array_get_array_set_other) }
    ultimately show "?I (it - {k}) (ahm_rehash_aux' sz (k, v) a')" by simp
  qed auto
  thus ?thesis1 ?thesis2 unfolding ahm_rehash_aux_def
    by(auto intro: ext)
qed

lemma ahm_rehash_correct:
  fixes hm :: "('key :: hashable, 'val) hashmap"
  assumes inv: "ahm_invar hm"
  and "sz > 1"
  shows "ahm_invar (ahm_rehash hm sz)" "ahm_α (ahm_rehash hm sz) = ahm_α hm"
using assms
by -(case_tac [!] hm, auto intro: ahm_rehash_aux_correct)

subsection @{term ahm_update}

lemma ahm_update_aux_correct:
  assumes inv: "ahm_invar hm"
  shows "ahm_invar (ahm_update_aux hm k v)" (is ?thesis1)
  and "ahm_α (ahm_update_aux hm k v) = (ahm_α hm)(k  v)" (is ?thesis2)
proof -
  obtain a n where [simp]: "hm = HashMap a n" by(cases hm)

  let ?h = "bounded_hashcode_nat (array_length a) k"
  let ?a' = "array_set a ?h (AList.update k v (array_get a ?h))"
  let ?n' = "if map_of (array_get a ?h) k = None then n + 1 else n"

  have "ahm_invar (HashMap ?a' ?n')" unfolding ahm_invar.simps
  proof(rule ahm_invar_auxI)
    fix h
    assume "h < array_length ?a'"
    hence "h < array_length a" by simp
    with inv have "bucket_ok (array_length a) h (array_get a h)"
      by(auto elim: ahm_invar_auxE)
    thus "bucket_ok (array_length ?a') h (array_get ?a' h)"
      using h < array_length a
      apply(cases "h = bounded_hashcode_nat (array_length a) k")
      apply(fastforce intro!: bucket_okI simp add: dom_update array_get_array_set_other dest: bucket_okD del: imageE elim: imageE)+
      done
    from h < array_length a inv have "distinct (map fst (array_get a h))"
      by(auto elim: ahm_invar_auxE)
    with h < array_length a
    show "distinct (map fst (array_get ?a' h))"
      by(cases "h = bounded_hashcode_nat (array_length a) k")(auto simp add: array_get_array_set_other intro: distinct_update)
  next
    obtain xs where a [simp]: "a = Array xs" by(cases a)

    let ?f = "λn kvs. n + length kvs"
    { fix n :: nat and xs :: "('a × 'b) list list"
      have "foldl ?f n xs = n + foldl ?f 0 xs"
        by(induct xs arbitrary:  rule: rev_induct) simp_all }
    note fold = this

    from inv have [simp]: "bounded_hashcode_nat (length xs) k < length xs"
      by(simp add: ahm_invar_aux_def bounded_hashcode_nat_bounds)
    have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
    from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
      by(auto elim: ahm_invar_auxE)
    hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
      by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
    thus "?n' = array_foldl (λ_ n kvs. n + length kvs) 0 ?a'"
      apply(simp add: ahm_rehash_aux'_def Let_def array_foldl_foldl foldl_list_update map_of_eq_None_iff)
      apply(subst (1 2 3 4 5 6 7 8) fold)
      apply(simp add: length_update)
      done
  next
    from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
    thus "1 < array_length ?a'" by simp
  qed
  moreover have "ahm_α (ahm_update_aux hm k v) = ahm_α hm(k  v)"
  proof
    fix k'
    from inv have "1 < array_length a" by(auto elim: ahm_invar_auxE)
    with bounded_hashcode_nat_bounds[OF this, of k]
    show "ahm_α (ahm_update_aux hm k v) k' = (ahm_α hm(k  v)) k'"
      by(cases "bounded_hashcode_nat (array_length a) k = bounded_hashcode_nat (array_length a) k'")(auto simp add: Let_def update_conv array_get_array_set_other)
  qed
  ultimately show ?thesis1 ?thesis2 by(simp_all add: Let_def)
qed

lemma ahm_update_correct:
  assumes inv: "ahm_invar hm"
  shows "ahm_invar (ahm_update k v hm)"
  and "ahm_α (ahm_update k v hm) = (ahm_α hm)(k  v)"
using assms
by(simp_all add: ahm_update_def Let_def ahm_rehash_correct ahm_update_aux_correct)

lemma ahm_update_impl:
  "map_update ahm_α ahm_invar ahm_update"
by(unfold_locales)(simp_all add: ahm_update_correct)

subsection @{term "ahm_delete"}

lemma ahm_delete_correct:
  assumes inv: "ahm_invar hm"
  shows "ahm_invar (ahm_delete k hm)" (is "?thesis1")
  and "ahm_α (ahm_delete k hm) = (ahm_α hm) |` (- {k})" (is "?thesis2")
proof -
  obtain a n where hm [simp]: "hm = HashMap a n" by(cases hm)

  let ?h = "bounded_hashcode_nat (array_length a) k"
  let ?a' = "array_set a ?h (AList.delete k (array_get a ?h))"
  let ?n' = "if map_of (array_get a (bounded_hashcode_nat (array_length a) k)) k = None then n else n - 1"
  
  have "ahm_invar_aux ?n' ?a'"
  proof(rule ahm_invar_auxI)
    fix h
    assume "h < array_length ?a'"
    hence "h < array_length a" by simp
    with inv have "bucket_ok (array_length a) h (array_get a h)"
      and "1 < array_length a" 
      and "distinct (map fst (array_get a h))" by(auto elim: ahm_invar_auxE)
    thus "bucket_ok (array_length ?a') h (array_get ?a' h)"
      and "distinct (map fst (array_get ?a' h))"
      using bounded_hashcode_nat_bounds[of "array_length a" k] 
      by-(case_tac [!] "h = bounded_hashcode_nat (array_length a) k", auto simp add: array_get_array_set_other set_delete_conv intro!: bucket_okI dest: bucket_okD intro: distinct_delete)
  next
    obtain xs where a [simp]: "a = Array xs" by(cases a)

    let ?f = "λn kvs. n + length kvs"
    { fix n :: nat and xs :: "('a × 'b) list list"
      have "foldl ?f n xs = n + foldl ?f 0 xs"
        by(induct xs arbitrary:  rule: rev_induct) simp_all }
    note fold = this

    from inv have [simp]: "bounded_hashcode_nat (length xs) k < length xs"
      by(simp add: ahm_invar_aux_def bounded_hashcode_nat_bounds)
    from inv have "distinct (map fst (array_get a ?h))" by(auto elim: ahm_invar_auxE)
    moreover
    have xs: "xs = take ?h xs @ (xs ! ?h) # drop (Suc ?h) xs" by(simp add: Cons_nth_drop_Suc)
    from inv have "n = array_foldl (λ_ n kvs. n + length kvs) 0 a"
      by(auto elim: ahm_invar_auxE)
    hence "n = foldl ?f 0 (take ?h xs) + length (xs ! ?h) + foldl ?f 0 (drop (Suc ?h) xs)"
      by(simp add: array_foldl_foldl)(subst xs, simp, subst (1 2 3 4) fold, simp)
    ultimately show "?n' = array_foldl (λ_ n kvs. n + length kvs) 0 ?a'"
      apply(simp add: array_foldl_foldl foldl_list_update map_of_eq_None_iff)
      apply(subst (1 2 3 4 5 6 7 8) fold)
      apply(auto simp add: length_distinct in_set_conv_nth)
      done
  next
    from inv show "1 < array_length ?a'" by(auto elim: ahm_invar_auxE)
  qed
  thus "?thesis1" by(auto simp add: Let_def)

  have "ahm_α_aux ?a' = ahm_α_aux a |` (- {k})"
  proof
    fix k' :: 'a
    from inv have "bounded_hashcode_nat (array_length a) k < array_length a"
      by(auto elim: ahm_invar_auxE simp add: bounded_hashcode_nat_bounds)
    thus "ahm_α_aux ?a' k' = (ahm_α_aux a |` (- {k})) k'"
      by(cases "?h = bounded_hashcode_nat (array_length a) k'")(auto simp add: restrict_map_def array_get_array_set_other delete_conv)
  qed
  thus ?thesis2 by(simp add: Let_def)
qed

lemma ahm_delete_impl:
  "map_delete ahm_α ahm_invar ahm_delete"
by(unfold_locales)(blast intro: ahm_delete_correct)+

hide_const (open) HashMap ahm_empty bucket_ok ahm_invar ahm_α ahm_lookup
  ahm_iteratei ahm_rehash hm_grow ahm_filled ahm_update ahm_delete
hide_type (open) hashmap

end

Theory ArrayHashMap

(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section ‹\isaheader{Array-based hash maps without explicit invariants}›
theory ArrayHashMap 
  imports ArrayHashMap_Impl
begin

(*@impl Map
  @type ('k,'v) ahm
  @abbrv ahm,a
  Array based hash maps without explicit invariant.
*)

subsection ‹Abstract type definition›

typedef (overloaded) ('key :: hashable, 'val) hashmap =
  "{hm :: ('key, 'val) ArrayHashMap_Impl.hashmap. ArrayHashMap_Impl.ahm_invar hm}"
  morphisms impl_of HashMap
proof
  interpret map_empty ArrayHashMap_Impl.ahm_α ArrayHashMap_Impl.ahm_invar ArrayHashMap_Impl.ahm_empty
    by(rule ahm_empty_impl)
  show "ArrayHashMap_Impl.ahm_empty ()  ?hashmap"
    by(simp add: empty_correct)
qed

type_synonym ('k,'v) ahm = "('k,'v) hashmap"

lemma ahm_invar_impl_of [simp, intro]: "ArrayHashMap_Impl.ahm_invar (impl_of hm)"
using impl_of[of hm] by simp

lemma HashMap_impl_of [code abstype]: "HashMap (impl_of t) = t"
by(rule impl_of_inverse)

subsection ‹Primitive operations›

definition ahm_empty_const :: "('key :: hashable, 'val) hashmap"
where "ahm_empty_const  (HashMap (ArrayHashMap_Impl.ahm_empty ()))"

definition ahm_empty :: "unit  ('key :: hashable, 'val) hashmap"
where "ahm_empty  λ_. ahm_empty_const"

definition ahm_α :: "('key :: hashable, 'val) hashmap  'key  'val option"
where "ahm_α hm = ArrayHashMap_Impl.ahm_α (impl_of hm)"

definition ahm_lookup :: "'key  ('key :: hashable, 'val) hashmap  'val option"
where "ahm_lookup k hm = ArrayHashMap_Impl.ahm_lookup k (impl_of hm)"

definition ahm_iteratei :: "('key :: hashable, 'val) hashmap  ('key × 'val, ) set_iterator"
where "ahm_iteratei hm = ArrayHashMap_Impl.ahm_iteratei (impl_of hm)"

definition ahm_update :: "'key  'val  ('key :: hashable, 'val) hashmap  ('key, 'val) hashmap"
where
  "ahm_update k v hm = HashMap (ArrayHashMap_Impl.ahm_update k v (impl_of hm))"

definition ahm_delete :: "'key  ('key :: hashable, 'val) hashmap  ('key, 'val) hashmap"
where
  "ahm_delete k hm = HashMap (ArrayHashMap_Impl.ahm_delete k (impl_of hm))"

lemma impl_of_ahm_empty [code abstract]:
  "impl_of ahm_empty_const = ArrayHashMap_Impl.ahm_empty ()"
by(simp add: ahm_empty_const_def HashMap_inverse)

lemma impl_of_ahm_update [code abstract]:
  "impl_of (ahm_update k v hm) = ArrayHashMap_Impl.ahm_update k v (impl_of hm)"
by(simp add: ahm_update_def HashMap_inverse ahm_update_correct)

lemma impl_of_ahm_delete [code abstract]:
  "impl_of (ahm_delete k hm) = ArrayHashMap_Impl.ahm_delete k (impl_of hm)"
by(simp add: ahm_delete_def HashMap_inverse ahm_delete_correct)

lemma finite_dom_ahm_α[simp]: "finite (dom (ahm_α hm))"
  by (simp add: ahm_α_def finite_dom_ahm_α)

lemma ahm_empty_correct[simp]: "ahm_α (ahm_empty ()) = Map.empty"
  by(simp add: ahm_α_def ahm_empty_def ahm_empty_const_def HashMap_inverse)

lemma ahm_lookup_correct[simp]: "ahm_lookup k m = ahm_α m k"
  by (simp add: ahm_lookup_def ArrayHashMap_Impl.ahm_lookup_def ahm_α_def)

lemma ahm_update_correct[simp]: "ahm_α (ahm_update k v hm) = (ahm_α hm)(k  v)"
  by (simp add: ahm_α_def ahm_update_def ahm_update_correct HashMap_inverse)

lemma ahm_delete_correct[simp]:
  "ahm_α (ahm_delete k hm) = (ahm_α hm) |` (- {k})"
  by (simp add: ahm_α_def ahm_delete_def HashMap_inverse ahm_delete_correct)

lemma ahm_iteratei_impl[simp]: "map_iterator (ahm_iteratei m) (ahm_α m)"
  unfolding ahm_iteratei_def ahm_α_def
  apply (rule ahm_iteratei_correct)
  by simp

subsection ‹ICF Integration›

definition [icf_rec_def]: "ahm_basic_ops  
  bmap_op_α = ahm_α,
  bmap_op_invar = λ_. True,
  bmap_op_empty = ahm_empty,
  bmap_op_lookup = ahm_lookup,
  bmap_op_update = ahm_update,
  bmap_op_update_dj = ahm_update, ― ‹TODO: We could use a more efficient bucket update here›
  bmap_op_delete = ahm_delete,
  bmap_op_list_it = ahm_iteratei
"

setup Locale_Code.open_block
interpretation ahm_basic: StdBasicMap ahm_basic_ops
  apply unfold_locales
  apply (simp_all add: icf_rec_unf)
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "ahm_ops  ahm_basic.dflt_ops"

setup Locale_Code.open_block
interpretation ahm: StdMap ahm_ops 
  unfolding ahm_ops_def
  by (rule ahm_basic.dflt_ops_impl)
interpretation ahm: StdMap_no_invar ahm_ops 
  apply unfold_locales
  unfolding icf_rec_unf ..
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "ahm"

lemma pi_ahm[proper_it]: 
  "proper_it' ahm_iteratei ahm_iteratei"
  unfolding ahm_iteratei_def[abs_def] 
    ArrayHashMap_Impl.ahm_iteratei_def ArrayHashMap_Impl.ahm_iteratei_aux_def
  apply (rule proper_it'I)
  apply (case_tac "impl_of s")
  apply simp
  apply (rename_tac array nat)
  apply (case_tac array)
  apply simp
  by (intro icf_proper_iteratorI)

interpretation pi_ahm: proper_it_loc ahm_iteratei ahm_iteratei
  apply unfold_locales
  apply (rule pi_ahm)
  done

text ‹Code generator test›
definition test_codegen where "test_codegen  (
  ahm.add ,
  ahm.add_dj ,
  ahm.ball ,
  ahm.bex ,
  ahm.delete ,
  ahm.empty ,
  ahm.isEmpty ,
  ahm.isSng ,
  ahm.iterate ,
  ahm.iteratei ,
  ahm.list_it ,
  ahm.lookup ,
  ahm.restrict ,
  ahm.sel ,
  ahm.size ,
  ahm.size_abort ,
  ahm.sng ,
  ahm.to_list ,
  ahm.to_map ,
  ahm.update ,
  ahm.update_dj)"

export_code test_codegen checking SML

end

Theory ArrayMapImpl

section ‹\isaheader{Maps from Naturals by Arrays}›
theory ArrayMapImpl
imports 
  "../spec/MapSpec"
  "../gen_algo/MapGA"
  "../../Lib/Diff_Array"
begin
  text_raw ‹\label{thy:ArrayMapImpl}›

(*@impl Map
  @type 'v iam
  @abbrv iam,im
  Maps of natural numbers implemented by arrays.
*)

  type_synonym 'v iam = "'v option array"

  subsection ‹Definitions›
  definition iam_α :: "'v iam  nat  'v" where
    "iam_α a i  if i < array_length a then array_get a i else None"

  lemma [code]: "iam_α a i  array_get_oo None a i"
    unfolding iam_α_def array_get_oo_def .

  abbreviation (input) iam_invar :: "'v iam  bool" 
    where "iam_invar  λ_. True"

  definition iam_empty :: "unit  'v iam" 
    where "iam_empty  λ_::unit. array_of_list []"

  definition iam_lookup :: "nat  'v iam  'v"
    where [code_unfold]: "iam_lookup k a  iam_α a k"

  definition "iam_increment (l::nat) idx  
    max (idx + 1 - l) (2 * l + 3)"

  lemma incr_correct: "¬ idx < l  idx < l + iam_increment l idx"
    unfolding iam_increment_def by auto

  definition iam_update :: "nat  'v  'v iam  'v iam"
    where "iam_update k v a  let
    l = array_length a;
    a = if k < l then a else array_grow a (iam_increment l k) None
  in
    array_set a k (Some v)
    "

  lemma [code]: "iam_update k v a  array_set_oo 
    (λ_. array_set 
           (array_grow a (iam_increment (array_length a) k) None) k (Some v))
    a k (Some v)
    "
    unfolding iam_update_def array_set_oo_def
    apply (rule eq_reflection)
    apply (auto simp add: Let_def)
    done

  definition "iam_update_dj  iam_update"

  definition iam_delete :: "nat  'v iam  'v iam"
    where "iam_delete k a  
    if k<array_length a then array_set a k None else a"

  lemma [code]: "iam_delete k a  array_set_oo (λ_. a) a k None"
    unfolding iam_delete_def array_set_oo_def by auto

  fun iam_rev_iterateoi_aux 
    :: "nat  ('v iam)  (bool)  (nat × 'v)    " 
    where
      "iam_rev_iterateoi_aux 0 a c f σ = σ"
    | "iam_rev_iterateoi_aux i a c f σ = (
        if c σ then   
          iam_rev_iterateoi_aux (i - 1) a c f (
            case array_get a (i - 1) of None  σ | Some x  f (i - 1, x) σ
          )
        else σ)"

  definition iam_rev_iterateoi :: "'v iam  (nat × 'v,) set_iterator" where 
    "iam_rev_iterateoi a  iam_rev_iterateoi_aux (array_length a) a"

  function iam_iterateoi_aux 
    :: "nat  nat  ('v iam)  (bool)  (nat × 'v)    " 
    where
      "iam_iterateoi_aux i len a c f σ =
        (if i  len  ¬ c σ then σ else let
            σ' = (case array_get a i of 
              None  σ 
            | Some x  f (i,x) σ)
          in iam_iterateoi_aux (i + 1) len a c f σ')"
    by pat_completeness auto
  termination 
    by (relation "measure (λ(i,l,_). l - i)") auto

  declare iam_iterateoi_aux.simps[simp del]

  lemma iam_iterateoi_aux_csimps:
    "i  len  iam_iterateoi_aux i len a c f σ = σ"
    "¬ c σ  iam_iterateoi_aux i len a c f σ = σ"
    " i< len; c σ   iam_iterateoi_aux i len a c f σ = 
      (case array_get a i of
        None  iam_iterateoi_aux (i + 1) len a c f σ
      | Some x  iam_iterateoi_aux (i + 1) len a c f (f (i,x) σ))"
    apply (subst iam_iterateoi_aux.simps, simp)
    apply (subst iam_iterateoi_aux.simps, simp)
    apply (subst iam_iterateoi_aux.simps)
    apply (auto split: option.split_asm option.split)
    done

  definition iam_iterateoi :: "'v iam  (nat × 'v,) set_iterator" where 
    "iam_iterateoi a = iam_iterateoi_aux 0 (array_length a) a"

  lemma iam_empty_impl: "map_empty iam_α iam_invar iam_empty"
    apply unfold_locales
    unfolding iam_α_def[abs_def] iam_empty_def
    by auto

  lemma iam_lookup_impl: "map_lookup iam_α iam_invar iam_lookup"
    apply unfold_locales
    unfolding iam_α_def[abs_def] iam_lookup_def
    by auto
  
  lemma array_get_set_iff: "i<array_length a  
    array_get (array_set a i x) j = (if i=j then x else array_get a j)"
    by (auto simp: array_get_array_set_other)

  lemma iam_update_impl: "map_update iam_α iam_invar iam_update"
    apply unfold_locales
    unfolding iam_α_def[abs_def] iam_update_def
    apply (rule ext)
    apply (auto simp: Let_def array_get_set_iff incr_correct)
    done

  lemma iam_update_dj_impl: "map_update_dj iam_α iam_invar iam_update_dj"
    apply (unfold iam_update_dj_def)
    apply (rule update_dj_by_update)
    apply (rule iam_update_impl)
    done

  lemma iam_delete_impl: "map_delete iam_α iam_invar iam_delete"
    apply unfold_locales
    unfolding iam_α_def[abs_def] iam_delete_def
    apply (rule ext)
    apply (auto simp: Let_def array_get_set_iff)
    done
  
  lemma iam_rev_iterateoi_aux_foldli_conv :
    "iam_rev_iterateoi_aux n a =
     foldli (List.map_filter (λn. map_option (λv. (n, v)) (array_get a n)) (rev [0..<n]))"
  by (induct n) (auto simp add: List.map_filter_def fun_eq_iff)

  lemma iam_rev_iterateoi_foldli_conv :
    "iam_rev_iterateoi a =
     foldli (List.map_filter 
       (λn. map_option (λv. (n, v)) (array_get a n)) 
       (rev [0..<(array_length a)]))"
    unfolding iam_rev_iterateoi_def iam_rev_iterateoi_aux_foldli_conv by simp

  lemma iam_rev_iterateoi_correct : 
  fixes m::"'a option array"
  defines "kvs  List.map_filter 
    (λn. map_option (λv. (n, v)) (array_get m n)) (rev [0..<(array_length m)])"
  shows "map_iterator_rev_linord (iam_rev_iterateoi m) (iam_α m)" 
  proof (rule map_iterator_rev_linord_I [of kvs])
    show "iam_rev_iterateoi m = foldli kvs"
      unfolding iam_rev_iterateoi_foldli_conv kvs_def by simp
  next
    define al where "al = array_length m"
    show dist_kvs: "distinct (map fst kvs)" and "sorted (rev (map fst kvs))"
      unfolding kvs_def al_def[symmetric]
      apply (induct al)
      apply (simp_all 
        add: List.map_filter_simps set_map_filter image_iff sorted_append
        split: option.split)
    done

    from dist_kvs
    have "i. map_of kvs i = iam_α m i"
      unfolding kvs_def 
      apply (case_tac "array_get m i")
      apply (simp_all 
        add: iam_α_def map_of_eq_None_iff set_map_filter image_iff)
    done
    thus "iam_α m = map_of kvs" by auto 
  qed
 
  lemma iam_rev_iterateoi_impl: 
    "poly_map_rev_iterateoi iam_α iam_invar iam_rev_iterateoi"
    apply unfold_locales
    apply (simp add: iam_α_def[abs_def] dom_def)
    apply (simp add: iam_rev_iterateoi_correct)
    done

  lemma iam_iteratei_impl: 
    "poly_map_iteratei iam_α iam_invar iam_rev_iterateoi"
  proof -
    interpret aux: poly_map_rev_iterateoi iam_α iam_invar iam_rev_iterateoi 
      by (rule iam_rev_iterateoi_impl) 

    show ?thesis
      apply unfold_locales
      apply (rule map_rev_iterator_linord_is_it)
      by (rule aux.list_rev_it_correct)
  qed

  lemma iam_iterateoi_aux_foldli_conv :
    "iam_iterateoi_aux n (array_length a) a c f σ =
     foldli (List.map_filter (λn. map_option (λv. (n, v)) (array_get a n)) 
       ([n..<array_length a])) c f σ"
    thm iam_iterateoi_aux.induct
    apply (induct n "array_length a" a c f σ rule: iam_iterateoi_aux.induct)
    apply (subst iam_iterateoi_aux.simps)
    apply (auto split: option.split simp: map_filter_simps)
    apply (subst (2) upt_conv_Cons)
    apply simp
    apply (simp add: map_filter_simps)
    apply (subst (2) upt_conv_Cons)
    apply simp
    apply (simp add: map_filter_simps)
    done

  lemma iam_iterateoi_foldli_conv :
    "iam_iterateoi a =
     foldli (List.map_filter 
       (λn. map_option (λv. (n, v)) (array_get a n)) 
       ([0..<(array_length a)]))"
    apply (intro ext)
    unfolding iam_iterateoi_def iam_iterateoi_aux_foldli_conv
    by simp

  (* TODO: Move to Misc *)
  lemmas [simp] = map_filter_simps
  lemma map_filter_append[simp]: "List.map_filter f (la@lb) 
    = List.map_filter f la @ List.map_filter f lb"
    by (induct la) (auto split: option.split)

  lemma iam_iterateoi_correct: 
  fixes m::"'a option array"
  defines "kvs  List.map_filter 
    (λn. map_option (λv. (n, v)) (array_get m n)) ([0..<(array_length m)])"
  shows "map_iterator_linord (iam_iterateoi m) (iam_α m)" 
  proof (rule map_iterator_linord_I [of kvs])
    show "iam_iterateoi m = foldli kvs"
      unfolding iam_iterateoi_foldli_conv kvs_def by simp
  next
    define al where "al = array_length m"
    show dist_kvs: "distinct (map fst kvs)" and "sorted (map fst kvs)"
      unfolding kvs_def al_def[symmetric]
      apply (induct al)
      apply (simp_all 
        add: set_map_filter image_iff sorted_append
        split: option.split)
    done

    from dist_kvs
    have "i. map_of kvs i = iam_α m i"
      unfolding kvs_def 
      apply (case_tac "array_get m i")
      apply (simp_all 
        add: iam_α_def map_of_eq_None_iff set_map_filter image_iff)
    done
    thus "iam_α m = map_of kvs" by auto 
  qed
 
  lemma iam_iterateoi_impl: 
    "poly_map_iterateoi iam_α iam_invar iam_iterateoi"
    apply unfold_locales
    apply (simp add: iam_α_def[abs_def] dom_def)
    apply (simp add: iam_iterateoi_correct)
    done

  definition iam_basic_ops :: "(nat,'a,'a iam) omap_basic_ops"
    where [icf_rec_def]: "iam_basic_ops  
    bmap_op_α = iam_α,
    bmap_op_invar = λ_. True,
    bmap_op_empty = iam_empty,
    bmap_op_lookup = iam_lookup,
    bmap_op_update = iam_update,
    bmap_op_update_dj = iam_update_dj,
    bmap_op_delete = iam_delete,
    bmap_op_list_it = iam_rev_iterateoi,
    bmap_op_ordered_list_it = iam_iterateoi,
    bmap_op_rev_list_it = iam_rev_iterateoi
    "

  setup Locale_Code.open_block
  interpretation iam_basic: StdBasicOMap iam_basic_ops
    apply (rule StdBasicOMap.intro)
    apply (rule StdBasicMap.intro)
    apply (simp_all add: icf_rec_unf)
    apply (rule iam_empty_impl iam_lookup_impl iam_update_impl
      iam_update_dj_impl iam_delete_impl iam_iteratei_impl
      iam_iterateoi_impl iam_rev_iterateoi_impl)+
    done
  setup Locale_Code.close_block

  definition [icf_rec_def]: "iam_ops  iam_basic.dflt_oops"

  setup Locale_Code.open_block
  interpretation iam: StdOMap iam_ops
    unfolding iam_ops_def
    by (rule iam_basic.dflt_oops_impl)
  interpretation iam: StdMap_no_invar iam_ops
    by unfold_locales (simp add: icf_rec_unf)
  setup Locale_Code.close_block
  setup ICF_Tools.revert_abbrevs "iam"

  lemma pi_iam[proper_it]: 
    "proper_it' iam_iterateoi iam_iterateoi"
    apply (rule proper_it'I)
    unfolding iam_iterateoi_foldli_conv
    by (rule icf_proper_iteratorI)

  lemma pi_iam_rev[proper_it]: 
    "proper_it' iam_rev_iterateoi iam_rev_iterateoi"
    apply (rule proper_it'I)
    unfolding iam_rev_iterateoi_foldli_conv
    by (rule icf_proper_iteratorI)

  interpretation pi_iam: proper_it_loc iam_iterateoi iam_iterateoi
    apply unfold_locales by (rule pi_iam)

  interpretation pi_iam_rev: proper_it_loc iam_rev_iterateoi iam_rev_iterateoi
    apply unfold_locales by (rule pi_iam_rev)

text ‹Code generator test›
definition "test_codegen  (
  iam.add ,
  iam.add_dj ,
  iam.ball ,
  iam.bex ,
  iam.delete ,
  iam.empty ,
  iam.isEmpty ,
  iam.isSng ,
  iam.iterate ,
  iam.iteratei ,
  iam.iterateo ,
  iam.iterateoi ,
  iam.list_it ,
  iam.lookup ,
  iam.max ,
  iam.min ,
  iam.restrict ,
  iam.rev_iterateo ,
  iam.rev_iterateoi ,
  iam.rev_list_it ,
  iam.reverse_iterateo ,
  iam.reverse_iterateoi ,
  iam.sel ,
  iam.size ,
  iam.size_abort ,
  iam.sng ,
  iam.to_list ,
  iam.to_map ,
  iam.to_rev_list ,
  iam.to_sorted_list ,
  iam.update ,
  iam.update_dj)"

export_code test_codegen checking SML
    
end

Theory MapStdImpl

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section "Standard Implementations of Maps"
theory MapStdImpl
imports 
  ListMapImpl 
  ListMapImpl_Invar 
  RBTMapImpl 
  HashMap 
  TrieMapImpl 
  ArrayHashMap
  ArrayMapImpl
begin
text_raw ‹\label{thy:MapStdImpl}›
text ‹
  This theory summarizes various standard implementation of maps, namely list-maps, RB-tree-maps, trie-maps, hashmaps, indexed array maps.
›
end

Theory ListSetImpl

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Set Implementation by List}›
theory ListSetImpl
imports "../spec/SetSpec" "../gen_algo/SetGA" "../../Lib/Dlist_add"
begin
text_raw ‹\label{thy:ListSetImpl}›

(*@impl Set
  @type 'a ls
  @abbrv ls,l
  Sets implemented by distinct lists. For efficient 
  @{text "insert_dj"}-operations, use the version with explicit invariant (lsi).
*)

type_synonym
  'a ls = "'a dlist"

subsection "Definitions"

definition ls_α :: "'a ls  'a set" where "ls_α l == set (list_of_dlist l)"

definition ls_basic_ops :: "('a,'a ls) set_basic_ops" where
  [icf_rec_def]: "ls_basic_ops  
    bset_op_α = ls_α,
    bset_op_invar = λ_. True,
    bset_op_empty = λ_. Dlist.empty,
    bset_op_memb = (λx s. Dlist.member s x),
    bset_op_ins = Dlist.insert,
    bset_op_ins_dj = Dlist.insert,
    bset_op_delete = dlist_remove',
    bset_op_list_it = dlist_iteratei
    "

setup Locale_Code.open_block
interpretation ls_basic: StdBasicSet ls_basic_ops
  apply unfold_locales
  unfolding ls_basic_ops_def ls_α_def[abs_def]
  apply (auto simp: dlist_member_empty Dlist.member_def List.member_def
    dlist_iteratei_correct
    dlist_remove'_correct set_dlist_remove1'
  )
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "ls_ops  ls_basic.dflt_ops 
  set_op_to_list := list_of_dlist
  "

setup Locale_Code.open_block
interpretation ls: StdSetDefs ls_ops .
interpretation ls: StdSet ls_ops
proof -
  interpret aux: StdSet ls_basic.dflt_ops
    by (rule ls_basic.dflt_ops_impl)

  show "StdSet ls_ops"
    unfolding ls_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (unfold_locales)
    apply (simp_all add: ls_α_def)
    done
qed

interpretation ls: StdSet_no_invar ls_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "ls"

lemma pi_ls[proper_it]:
  "proper_it' dlist_iteratei dlist_iteratei"
  apply (rule proper_it'I)
  unfolding dlist_iteratei_def
  by (intro icf_proper_iteratorI)

lemma pi_ls'[proper_it]: 
  "proper_it' ls.iteratei ls.iteratei"
  apply (rule proper_it'I)
  unfolding ls.iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_ls: proper_it_loc dlist_iteratei dlist_iteratei
  apply unfold_locales by (rule pi_ls)

interpretation pi_ls': proper_it_loc ls.iteratei ls.iteratei
  apply unfold_locales by (rule pi_ls')

definition test_codegen where "test_codegen  (
  ls.empty,
  ls.memb,
  ls.ins,
  ls.delete,
  ls.list_it,
  ls.sng,
  ls.isEmpty,
  ls.isSng,
  ls.ball,
  ls.bex,
  ls.size,
  ls.size_abort,
  ls.union,
  ls.union_dj,
  ls.diff,
  ls.filter,
  ls.inter,
  ls.subset,
  ls.equal,
  ls.disjoint,
  ls.disjoint_witness,
  ls.sel,
  ls.to_list,
  ls.from_list
)"

export_code test_codegen checking SML

end

Theory ListSetImpl_Invar

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Set Implementation by List with explicit invariants}›
theory ListSetImpl_Invar
  imports 
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  "../../Lib/Dlist_add"
begin
text_raw ‹\label{thy:ListSetImpl_Invar}›

(*@impl Set
  @type 'a lsi
  @abbrv lsi,l
  Sets by lists with distinct elements. Version with explicit invariant that 
  supports efficient @{text "insert_dj"} operation.
*)

type_synonym
  'a lsi = "'a list"

subsection "Definitions"

definition lsi_ins :: "'a  'a lsi  'a lsi" where "lsi_ins x l == if  List.member l x then l else x#l"

definition lsi_basic_ops :: "('a,'a lsi) set_basic_ops" where
  [icf_rec_def]: "lsi_basic_ops  
    bset_op_α = set,
    bset_op_invar = distinct,
    bset_op_empty = λ_. [],
    bset_op_memb = (λx s. List.member s x),
    bset_op_ins = lsi_ins,
    bset_op_ins_dj = (#),
    bset_op_delete = λx l. Dlist_add.dlist_remove1' x [] l,
    bset_op_list_it = foldli
    "

setup Locale_Code.open_block
interpretation lsi_basic: StdBasicSet lsi_basic_ops
  apply unfold_locales
  unfolding lsi_basic_ops_def lsi_ins_def[abs_def]
  apply (auto simp: List.member_def set_dlist_remove1' 
  distinct_remove1')
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lsi_ops  lsi_basic.dflt_ops 
  set_op_union_dj := (@),
  set_op_to_list := id
"

setup Locale_Code.open_block
interpretation lsi: StdSet lsi_ops
proof -
  interpret aux: StdSet lsi_basic.dflt_ops by (rule lsi_basic.dflt_ops_impl)

  show "StdSet lsi_ops"
    unfolding lsi_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (unfold_locales, auto)
    done
qed
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "lsi"

lemma pi_lsi[proper_it]: 
  "proper_it' foldli foldli"
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lsi: proper_it_loc foldli foldli
  apply unfold_locales by (rule pi_lsi)

definition test_codegen where "test_codegen  (
  lsi.empty,
  lsi.memb,
  lsi.ins,
  lsi.delete,
  lsi.list_it,
  lsi.sng,
  lsi.isEmpty,
  lsi.isSng,
  lsi.ball,
  lsi.bex,
  lsi.size,
  lsi.size_abort,
  lsi.union,
  lsi.union_dj,
  lsi.diff,
  lsi.filter,
  lsi.inter,
  lsi.subset,
  lsi.equal,
  lsi.disjoint,
  lsi.disjoint_witness,
  lsi.sel,
  lsi.to_list,
  lsi.from_list
)"

export_code test_codegen checking SML

end

Theory ListSetImpl_NotDist

(*  Title:       Isabelle Collections Library
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section ‹\isaheader{Set Implementation by non-distinct Lists}›
theory ListSetImpl_NotDist
imports 
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  (*"../common/ListAdd"*)
begin
text_raw ‹\label{thy:ListSetImpl_NotDist}›

(*@impl Set
  @type 'a lsnd
  @abbrv lsnd
  Sets implemented by lists that may contain duplicate elements. 
  Insertion is quick, but other operations are less performant than on 
  lists with distinct elements.
*)

type_synonym
  'a lsnd = "'a list"

subsection "Definitions"

definition lsnd_α :: "'a lsnd  'a set" where "lsnd_α == set"
abbreviation (input) lsnd_invar 
  :: "'a lsnd  bool" where "lsnd_invar == (λ_. True)"
definition lsnd_empty :: "unit  'a lsnd" where "lsnd_empty == (λ_::unit. [])"
definition lsnd_memb :: "'a  'a lsnd  bool" where "lsnd_memb x l == List.member l x"
definition lsnd_ins :: "'a  'a lsnd  'a lsnd" where "lsnd_ins x l == x#l"
definition lsnd_ins_dj :: "'a  'a lsnd  'a lsnd" where "lsnd_ins_dj x l == x#l"

definition lsnd_delete :: "'a  'a lsnd  'a lsnd" where "lsnd_delete x l == remove_rev x l"

definition lsnd_iteratei :: "'a lsnd  ('a,) set_iterator" 
where "lsnd_iteratei l = foldli (remdups l)"

definition lsnd_isEmpty :: "'a lsnd  bool" where "lsnd_isEmpty s == s=[]"

definition lsnd_union :: "'a lsnd  'a lsnd  'a lsnd" 
  where "lsnd_union s1 s2 == revg s1 s2"
definition lsnd_union_dj :: "'a lsnd  'a lsnd  'a lsnd" 
  where "lsnd_union_dj s1 s2 == revg s1 s2" ― ‹Union of disjoint sets›

definition lsnd_to_list :: "'a lsnd  'a list" where "lsnd_to_list == remdups"
definition list_to_lsnd :: "'a list  'a lsnd" where "list_to_lsnd == id"

subsection "Correctness"
lemmas lsnd_defs = 
  lsnd_α_def
  lsnd_empty_def
  lsnd_memb_def
  lsnd_ins_def
  lsnd_ins_dj_def
  lsnd_delete_def
  lsnd_iteratei_def
  lsnd_isEmpty_def
  lsnd_union_def
  lsnd_union_dj_def
  lsnd_to_list_def
  list_to_lsnd_def

lemma lsnd_empty_impl: "set_empty lsnd_α lsnd_invar lsnd_empty"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_memb_impl: "set_memb lsnd_α lsnd_invar lsnd_memb"
by (unfold_locales)(auto simp add: lsnd_defs in_set_member)

lemma lsnd_ins_impl: "set_ins lsnd_α lsnd_invar lsnd_ins"
by (unfold_locales) (auto simp add: lsnd_defs in_set_member)

lemma lsnd_ins_dj_impl: "set_ins_dj lsnd_α lsnd_invar lsnd_ins_dj"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_delete_impl: "set_delete lsnd_α lsnd_invar lsnd_delete"
by (unfold_locales) (auto simp add: lsnd_delete_def lsnd_α_def remove_rev_alt_def)

lemma lsnd_α_finite[simp, intro!]: "finite (lsnd_α l)"
  by (auto simp add: lsnd_defs)

lemma lsnd_is_finite_set: "finite_set lsnd_α lsnd_invar"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_iteratei_impl: "poly_set_iteratei lsnd_α lsnd_invar lsnd_iteratei"
proof 
  fix l :: "'a list"
  show "finite (lsnd_α l)"
    unfolding lsnd_α_def by simp

  show "set_iterator (lsnd_iteratei l) (lsnd_α l)"
    apply (rule set_iterator_I [of "remdups l"])
    apply (simp_all add: lsnd_α_def lsnd_iteratei_def)
  done
qed

lemma lsnd_isEmpty_impl: "set_isEmpty lsnd_α lsnd_invar lsnd_isEmpty"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_union_impl: "set_union lsnd_α lsnd_invar lsnd_α lsnd_invar lsnd_α lsnd_invar lsnd_union"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_union_dj_impl: "set_union_dj lsnd_α lsnd_invar lsnd_α lsnd_invar lsnd_α lsnd_invar lsnd_union_dj"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_to_list_impl: "set_to_list lsnd_α lsnd_invar lsnd_to_list"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma list_to_lsnd_impl: "list_to_set lsnd_α lsnd_invar list_to_lsnd"
by(unfold_locales)(auto simp add: lsnd_defs)

definition lsnd_basic_ops :: "('x,'x lsnd) set_basic_ops" 
  where [icf_rec_def]: "lsnd_basic_ops  
    bset_op_α = lsnd_α,
    bset_op_invar = lsnd_invar,
    bset_op_empty = lsnd_empty,
    bset_op_memb = lsnd_memb,
    bset_op_ins = lsnd_ins,
    bset_op_ins_dj = lsnd_ins_dj,
    bset_op_delete = lsnd_delete,
    bset_op_list_it = lsnd_iteratei
  "

setup Locale_Code.open_block
interpretation lsnd_basic: StdBasicSet lsnd_basic_ops
  apply (rule StdBasicSet.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule lsnd_empty_impl lsnd_memb_impl lsnd_ins_impl lsnd_ins_dj_impl
    lsnd_delete_impl lsnd_iteratei_impl)+
  done
setup Locale_Code.close_block


definition [icf_rec_def]: "lsnd_ops  lsnd_basic.dflt_ops 
  set_op_isEmpty := lsnd_isEmpty,
  set_op_union := lsnd_union,
  set_op_union_dj := lsnd_union_dj,
  set_op_to_list := lsnd_to_list,
  set_op_from_list := list_to_lsnd
  "

setup Locale_Code.open_block
interpretation lsnd: StdSetDefs lsnd_ops .
interpretation lsnd: StdSet lsnd_ops
proof -
  interpret aux: StdSet lsnd_basic.dflt_ops
    by (rule lsnd_basic.dflt_ops_impl)

  show "StdSet lsnd_ops"
    unfolding lsnd_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf
      lsnd_isEmpty_impl lsnd_union_impl lsnd_union_dj_impl lsnd_to_list_impl
      list_to_lsnd_impl
    )
    done
qed
interpretation lsnd: StdSet_no_invar lsnd_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "lsnd"

lemma pi_lsnd[proper_it]: 
  "proper_it' lsnd_iteratei lsnd_iteratei"
  apply (rule proper_it'I)
  unfolding lsnd_iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_lsnd: proper_it_loc lsnd_iteratei lsnd_iteratei
  apply unfold_locales by (rule pi_lsnd)

definition test_codegen where "test_codegen  (
  lsnd.empty,
  lsnd.memb,
  lsnd.ins,
  lsnd.delete,
  lsnd.list_it,
  lsnd.sng,
  lsnd.isEmpty,
  lsnd.isSng,
  lsnd.ball,
  lsnd.bex,
  lsnd.size,
  lsnd.size_abort,
  lsnd.union,
  lsnd.union_dj,
  lsnd.diff,
  lsnd.filter,
  lsnd.inter,
  lsnd.subset,
  lsnd.equal,
  lsnd.disjoint,
  lsnd.disjoint_witness,
  lsnd.sel,
  lsnd.to_list,
  lsnd.from_list
)"

export_code test_codegen checking SML

end

Theory ListSetImpl_Sorted

(*  Title:       Isabelle Collections Library
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section ‹\isaheader{Set Implementation by sorted Lists}›
theory ListSetImpl_Sorted
imports 
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  "../../Lib/Sorted_List_Operations"
begin
text_raw ‹\label{thy:ListSetImpl_Sorted}›

(*@impl Set
  @type 'a::linorder lss
  @abbrv lss
  Sets implemented by sorted lists.
*)

type_synonym
  'a lss = "'a list"

subsection "Definitions"
definition lss_α :: "'a lss  'a set" where "lss_α == set"
definition lss_invar :: "'a::{linorder} lss  bool" where "lss_invar l == distinct l  sorted l"
definition lss_empty :: "unit  'a lss" where "lss_empty == (λ_::unit. [])"
definition lss_memb :: "'a::{linorder}  'a lss  bool" where "lss_memb x l == Sorted_List_Operations.memb_sorted l x"
definition lss_ins :: "'a::{linorder}  'a lss  'a lss" where "lss_ins x l == insertion_sort x l"
definition lss_ins_dj :: "'a::{linorder}  'a lss  'a lss" where "lss_ins_dj == lss_ins"

definition lss_delete :: "'a::{linorder}  'a lss  'a lss" where "lss_delete x l == delete_sorted x l"

definition lss_iterateoi :: "'a lss  ('a,) set_iterator" 
where "lss_iterateoi l = foldli l"

definition lss_reverse_iterateoi :: "'a lss  ('a,) set_iterator" 
where "lss_reverse_iterateoi l = foldli (rev l)"

definition lss_iteratei :: "'a lss  ('a,) set_iterator" 
where "lss_iteratei l = foldli l"

definition lss_isEmpty :: "'a lss  bool" where "lss_isEmpty s == s=[]"

definition lss_union :: "'a::{linorder} lss  'a lss  'a lss" 
  where "lss_union s1 s2 == Misc.merge s1 s2"
definition lss_union_list :: "'a::{linorder} lss list  'a lss" 
  where "lss_union_list l == merge_list [] l"
definition lss_inter :: "'a::{linorder} lss  'a lss  'a lss" 
  where "lss_inter == inter_sorted"
definition lss_union_dj :: "'a::{linorder} lss  'a lss  'a lss" 
  where "lss_union_dj == lss_union" ― ‹Union of disjoint sets›

definition lss_image_filter 
  where "lss_image_filter f l = 
         mergesort_remdups (List.map_filter f l)"

definition lss_filter where [code_unfold]: "lss_filter = List.filter"

definition lss_inj_image_filter 
  where "lss_inj_image_filter == lss_image_filter"

definition "lss_image == iflt_image lss_image_filter"
definition "lss_inj_image == iflt_inj_image lss_inj_image_filter"

definition lss_to_list :: "'a lss  'a list" where "lss_to_list == id"
definition list_to_lss :: "'a::{linorder} list  'a lss" where "list_to_lss == mergesort_remdups"

subsection "Correctness"
lemmas lss_defs = 
  lss_α_def
  lss_invar_def
  lss_empty_def
  lss_memb_def
  lss_ins_def
  lss_ins_dj_def
  lss_delete_def
  lss_iteratei_def
  lss_isEmpty_def
  lss_union_def
  lss_union_list_def
  lss_inter_def
  lss_union_dj_def
  lss_image_filter_def
  lss_inj_image_filter_def
  lss_image_def
  lss_inj_image_def
  lss_to_list_def
  list_to_lss_def

lemma lss_empty_impl: "set_empty lss_α lss_invar lss_empty"
by (unfold_locales) (auto simp add: lss_defs)

lemma lss_memb_impl: "set_memb lss_α lss_invar lss_memb"
by (unfold_locales) (auto simp add: lss_defs memb_sorted_correct)

lemma lss_ins_impl: "set_ins lss_α lss_invar lss_ins"
by (unfold_locales) (auto simp add: lss_defs insertion_sort_correct)

lemma lss_ins_dj_impl: "set_ins_dj lss_α lss_invar lss_ins_dj"
by (unfold_locales) (auto simp add: lss_defs insertion_sort_correct)

lemma lss_delete_impl: "set_delete lss_α lss_invar lss_delete"
by(unfold_locales)(auto simp add: lss_delete_def lss_α_def lss_invar_def delete_sorted_correct)

lemma lss_α_finite[simp, intro!]: "finite (lss_α l)"
  by (auto simp add: lss_defs)

lemma lss_is_finite_set: "finite_set lss_α lss_invar"
by (unfold_locales) (auto simp add: lss_defs)

lemma lss_iterateoi_impl: "poly_set_iterateoi lss_α lss_invar lss_iterateoi"
proof 
  fix l :: "'a::{linorder} list"
  assume invar_l: "lss_invar l"
  show "finite (lss_α l)"
    unfolding lss_α_def by simp

  from invar_l
  show "set_iterator_linord (lss_iterateoi l) (lss_α l)"
    apply (rule_tac set_iterator_linord_I [of "l"])
    apply (simp_all add: lss_α_def lss_invar_def lss_iterateoi_def)
  done
qed

lemma lss_reverse_iterateoi_impl: "poly_set_rev_iterateoi lss_α lss_invar lss_reverse_iterateoi"
proof 
  fix l :: "'a list"
  assume invar_l: "lss_invar l"
  show "finite (lss_α l)"
    unfolding lss_α_def by simp

  from invar_l
  show "set_iterator_rev_linord (lss_reverse_iterateoi l) (lss_α l)"
    apply (rule_tac set_iterator_rev_linord_I [of "rev l"])
    apply (simp_all add: lss_α_def lss_invar_def lss_reverse_iterateoi_def)
  done
qed

lemma lss_iteratei_impl: "poly_set_iteratei lss_α lss_invar lss_iteratei"
proof 
  fix l :: "'a list"
  assume invar_l: "lss_invar l"
  show "finite (lss_α l)"
    unfolding lss_α_def by simp

  from invar_l
  show "set_iterator (lss_iteratei l) (lss_α l)"
    apply (rule_tac set_iterator_I [of "l"])
    apply (simp_all add: lss_α_def lss_invar_def lss_iteratei_def)
  done
qed

lemma lss_isEmpty_impl: "set_isEmpty lss_α lss_invar lss_isEmpty"
by(unfold_locales)(auto simp add: lss_defs)

lemma lss_inter_impl: "set_inter lss_α lss_invar lss_α lss_invar lss_α lss_invar lss_inter"
by (unfold_locales) (auto simp add: lss_defs inter_sorted_correct)

lemma lss_union_impl: "set_union lss_α lss_invar lss_α lss_invar lss_α lss_invar lss_union"
by (unfold_locales) (auto simp add: lss_defs merge_correct)

lemma lss_union_list_impl: "set_union_list lss_α lss_invar lss_α lss_invar lss_union_list"
proof 
  fix l :: "'a::{linorder} lss list"
  assume "s1set l. lss_invar s1"

  with merge_list_correct [of l "[]"]
  show "lss_α (lss_union_list l) = {lss_α s1 |s1. s1  set l}"
       "lss_invar (lss_union_list l)"
    by (auto simp add: lss_defs)
qed

lemma lss_union_dj_impl: "set_union_dj lss_α lss_invar lss_α lss_invar lss_α lss_invar lss_union_dj"
by (unfold_locales) (auto simp add: lss_defs merge_correct)

lemma lss_image_filter_impl : "set_image_filter lss_α lss_invar lss_α lss_invar lss_image_filter"
apply (unfold_locales)
apply (simp_all add: 
  lss_invar_def lss_image_filter_def lss_α_def mergesort_remdups_correct
  set_map_filter Bex_def)
done

lemma lss_inj_image_filter_impl : "set_inj_image_filter lss_α lss_invar lss_α lss_invar lss_inj_image_filter"
apply (unfold_locales)
apply (simp_all add: lss_invar_def lss_inj_image_filter_def lss_image_filter_def
                     mergesort_remdups_correct lss_α_def
                     set_map_filter Bex_def)
done

lemma lss_filter_impl : "set_filter lss_α lss_invar lss_α lss_invar lss_filter"
apply (unfold_locales)
apply (simp_all add: lss_invar_def lss_filter_def sorted_filter lss_α_def
                     set_map_filter Bex_def sorted_filter')
done

lemmas lss_image_impl = iflt_image_correct[OF lss_image_filter_impl, folded lss_image_def]
lemmas lss_inj_image_impl = iflt_inj_image_correct[OF lss_inj_image_filter_impl, folded lss_inj_image_def]

lemma lss_to_list_impl: "set_to_list lss_α lss_invar lss_to_list"
by(unfold_locales)(auto simp add: lss_defs)

lemma list_to_lss_impl: "list_to_set lss_α lss_invar list_to_lss"
  by (unfold_locales) (auto simp add: lss_defs mergesort_remdups_correct)


definition lss_basic_ops :: "('x::linorder,'x lss) oset_basic_ops" 
  where [icf_rec_def]: "lss_basic_ops  
    bset_op_α = lss_α,
    bset_op_invar = lss_invar,
    bset_op_empty = lss_empty,
    bset_op_memb = lss_memb,
    bset_op_ins = lss_ins,
    bset_op_ins_dj = lss_ins_dj,
    bset_op_delete = lss_delete,
    bset_op_list_it = lss_iteratei,
    bset_op_ordered_list_it = lss_iterateoi,
    bset_op_rev_list_it = lss_reverse_iterateoi
  "

setup Locale_Code.open_block
interpretation lss_basic: StdBasicOSet lss_basic_ops
  apply (rule StdBasicOSet.intro)
  apply (rule StdBasicSet.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule lss_empty_impl lss_memb_impl lss_ins_impl lss_ins_dj_impl
    lss_delete_impl lss_iteratei_impl lss_iterateoi_impl 
    lss_reverse_iterateoi_impl)+
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lss_ops  lss_basic.dflt_oops 
  set_op_isEmpty := lss_isEmpty,
  set_op_union := lss_union,
  set_op_union_dj := lss_union_dj,
  set_op_filter := lss_filter,
  set_op_to_list := lss_to_list,
  set_op_from_list := list_to_lss
  "

setup Locale_Code.open_block
interpretation lss: StdOSetDefs lss_ops .
interpretation lss: StdOSet lss_ops
proof -
  interpret aux: StdOSet lss_basic.dflt_oops
    by (rule lss_basic.dflt_oops_impl)

  show "StdOSet lss_ops"
    unfolding lss_ops_def
    apply (rule StdOSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf
      lss_isEmpty_impl lss_union_impl lss_union_dj_impl lss_to_list_impl
      lss_filter_impl
      list_to_lss_impl
    )
    done
qed
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "lss"

lemma pi_lss[proper_it]: 
  "proper_it' lss_iteratei lss_iteratei"
  apply (rule proper_it'I)
  unfolding lss_iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_lss: proper_it_loc lss_iteratei lss_iteratei
  apply unfold_locales by (rule pi_lss)

definition test_codegen where "test_codegen  (
  lss.empty,
  lss.memb,
  lss.ins,
  lss.delete,
  lss.list_it,
  lss.sng,
  lss.isEmpty,
  lss.isSng,
  lss.ball,
  lss.bex,
  lss.size,
  lss.size_abort,
  lss.union,
  lss.union_dj,
  lss.diff,
  lss.filter,
  lss.inter,
  lss.subset,
  lss.equal,
  lss.disjoint,
  lss.disjoint_witness,
  lss.sel,
  lss.to_list,
  lss.from_list
)"

export_code test_codegen checking SML

end

Theory RBTSetImpl

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedSet, implemented iterators, min, max, to_sorted_list

*)

section ‹\isaheader{Set Implementation by Red-Black-Tree}›
theory RBTSetImpl
imports 
  "../spec/SetSpec"
  RBTMapImpl
  "../gen_algo/SetByMap"
  "../gen_algo/SetGA"
begin
text_raw ‹\label{thy:RBTSetImpl}›
(*@impl Set
  @type ('a::linorder) rs
  @abbrv rs,r
  Sets over linearly ordered elements implemented by red-black trees.
*)

subsection "Definitions"
type_synonym
  'a rs = "('a::linorder,unit) rm"

setup Locale_Code.open_block
interpretation rs_sbm: OSetByOMap rm_basic_ops by unfold_locales
setup Locale_Code.close_block

definition rs_ops :: "('x::linorder,'x rs) oset_ops"
  where [icf_rec_def]: "rs_ops  rs_sbm.obasic.dflt_oops"

setup Locale_Code.open_block
interpretation rs: StdOSetDefs rs_ops .
interpretation rs: StdOSet rs_ops
  unfolding rs_ops_def
  by (rule rs_sbm.obasic.dflt_oops_impl)

interpretation rs: StdSet_no_invar rs_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "rs"

lemmas rbt_it_to_it_map_code_unfold[code_unfold] = 
  it_to_it_map_fold'[OF pi_rm]
  it_to_it_map_fold'[OF pi_rm_rev]

lemma pi_rs[proper_it]:
  "proper_it' rs.iteratei rs.iteratei"
  "proper_it' rs.iterateoi rs.iterateoi"
  "proper_it' rs.rev_iterateoi rs.rev_iterateoi"
  unfolding rs.iteratei_def[abs_def] rs.iterateoi_def[abs_def] 
    rs.rev_iterateoi_def[abs_def]
  by (rule proper_it'I icf_proper_iteratorI)+

interpretation
  pi_rs: proper_it_loc rs.iteratei rs.iteratei +
  pi_rs_o: proper_it_loc rs.iterateoi rs.iterateoi +
  pi_rs_ro: proper_it_loc rs.rev_iterateoi rs.rev_iterateoi
  by unfold_locales (rule pi_rs)+

definition test_codegen where "test_codegen  (
  rs.empty,
  rs.memb,
  rs.ins,
  rs.delete,
  rs.list_it,
  rs.sng,
  rs.isEmpty,
  rs.isSng,
  rs.ball,
  rs.bex,
  rs.size,
  rs.size_abort,
  rs.union,
  rs.union_dj,
  rs.diff,
  rs.filter,
  rs.inter,
  rs.subset,
  rs.equal,
  rs.disjoint,
  rs.disjoint_witness,
  rs.sel,
  rs.to_list,
  rs.from_list,

  rs.ordered_list_it,
  rs.rev_list_it,
  rs.min, 
  rs.max, 
  rs.to_sorted_list,
  rs.to_rev_list
)"

export_code test_codegen checking SML

end

Theory HashSet

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Hash Set}›
theory HashSet
  imports 
  "../spec/SetSpec" 
  HashMap 
  "../gen_algo/SetByMap" 
  "../gen_algo/SetGA"
begin
text_raw ‹\label{thy:HashSet}›
(*@impl Set
  @type 'a::hashable hs
  @abbrv hs,h
  Hash sets based on red-black trees.
*)

subsection "Definitions"
type_synonym
  'a hs = "('a::hashable,unit) hm"

setup Locale_Code.open_block
interpretation hs_sbm: SetByMap hm_basic_ops by unfold_locales
setup Locale_Code.close_block

definition hs_ops :: "('a::hashable,'a hs) set_ops"
  where [icf_rec_def]:
  "hs_ops  hs_sbm.basic.dflt_ops"

setup Locale_Code.open_block
interpretation hs: StdSet hs_ops
  unfolding hs_ops_def by (rule hs_sbm.basic.dflt_ops_impl)
interpretation hs: StdSet_no_invar hs_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "hs"

lemmas hs_it_to_it_map_code_unfold[code_unfold] = 
  it_to_it_map_fold'[OF pi_hm]

lemma pi_hs[proper_it]: "proper_it' hs.iteratei hs.iteratei"
  unfolding hs.iteratei_def[abs_def]
  by (rule proper_it'I icf_proper_iteratorI)+

interpretation pi_hs: proper_it_loc hs.iteratei hs.iteratei
  by unfold_locales (rule pi_hs)

definition test_codegen where "test_codegen  (
  hs.empty,
  hs.memb,
  hs.ins,
  hs.delete,
  hs.list_it,
  hs.sng,
  hs.isEmpty,
  hs.isSng,
  hs.ball,
  hs.bex,
  hs.size,
  hs.size_abort,
  hs.union,
  hs.union_dj,
  hs.diff,
  hs.filter,
  hs.inter,
  hs.subset,
  hs.equal,
  hs.disjoint,
  hs.disjoint_witness,
  hs.sel,
  hs.to_list,
  hs.from_list
)"

export_code test_codegen checking SML

end

Theory TrieSetImpl

(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section ‹\isaheader{Set implementation via tries}›
theory TrieSetImpl imports
  TrieMapImpl
  "../gen_algo/SetByMap"
  "../gen_algo/SetGA"
begin

(*@impl Set
  @type ('a) ts
  @abbrv ts,t
  Sets of elements of type @{typ "'a list"} implemented by tries.
*)

subsection "Definitions"

type_synonym
  'a ts = "('a, unit) trie"

setup Locale_Code.open_block
interpretation ts_sbm: SetByMap tm_basic_ops by unfold_locales
setup Locale_Code.close_block

definition ts_ops :: "('a list,'a ts) set_ops"
  where [icf_rec_def]:
  "ts_ops  ts_sbm.basic.dflt_ops"

setup Locale_Code.open_block
interpretation ts: StdSet ts_ops
  unfolding ts_ops_def by (rule ts_sbm.basic.dflt_ops_impl)
interpretation ts: StdSet_no_invar ts_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "ts"

lemmas ts_it_to_it_map_code_unfold[code_unfold] = 
  it_to_it_map_fold'[OF pi_trie]

lemma pi_ts[proper_it]: "proper_it' ts.iteratei ts.iteratei"
  unfolding ts.iteratei_def[abs_def]
  by (rule proper_it'I icf_proper_iteratorI)+

interpretation pi_ts: proper_it_loc ts.iteratei ts.iteratei
  by unfold_locales (rule pi_ts)

definition test_codegen where "test_codegen  (
  ts.empty,
  ts.memb,
  ts.ins,
  ts.delete,
  ts.list_it,
  ts.sng,
  ts.isEmpty,
  ts.isSng,
  ts.ball,
  ts.bex,
  ts.size,
  ts.size_abort,
  ts.union,
  ts.union_dj,
  ts.diff,
  ts.filter,
  ts.inter,
  ts.subset,
  ts.equal,
  ts.disjoint,
  ts.disjoint_witness,
  ts.sel,
  ts.to_list,
  ts.from_list
)"

export_code test_codegen checking SML

end

Theory ArrayHashSet

(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
theory ArrayHashSet
imports 
  ArrayHashMap 
  "../gen_algo/SetByMap"
  "../gen_algo/SetGA"
begin

(*@impl Set
  @type ('a) ahs
  @abbrv ahs,a
  Array based hash sets without explicit invariant.
*)

subsection "Definitions"
type_synonym
  'a ahs = "('a::hashable,unit) ahm"

setup Locale_Code.open_block
interpretation ahs_sbm: SetByMap ahm_basic_ops by unfold_locales
setup Locale_Code.close_block

definition ahs_ops :: "('a::hashable,'a ahs) set_ops"
  where [icf_rec_def]:
  "ahs_ops  ahs_sbm.basic.dflt_ops"

setup Locale_Code.open_block
interpretation ahs: StdSet ahs_ops
  unfolding ahs_ops_def by (rule ahs_sbm.basic.dflt_ops_impl)
interpretation ahs: StdSet_no_invar ahs_ops 
  apply unfold_locales
  by (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "ahs"

lemmas ahs_it_to_it_map_code_unfold[code_unfold] = 
  it_to_it_map_fold'[OF pi_ahm]

lemma pi_ahs[proper_it]: "proper_it' ahs.iteratei ahs.iteratei"
  unfolding ahs.iteratei_def[abs_def]
  by (rule proper_it'I icf_proper_iteratorI)+

interpretation pi_ahs: proper_it_loc ahs.iteratei ahs.iteratei
  by unfold_locales (rule pi_ahs)

definition test_codegen where "test_codegen  (
  ahs.empty,
  ahs.memb,
  ahs.ins,
  ahs.delete,
  ahs.list_it,
  ahs.sng,
  ahs.isEmpty,
  ahs.isSng,
  ahs.ball,
  ahs.bex,
  ahs.size,
  ahs.size_abort,
  ahs.union,
  ahs.union_dj,
  ahs.diff,
  ahs.filter,
  ahs.inter,
  ahs.subset,
  ahs.equal,
  ahs.disjoint,
  ahs.disjoint_witness,
  ahs.sel,
  ahs.to_list,
  ahs.from_list
)"

export_code test_codegen checking SML

end

Theory ArraySetImpl

section ‹\isaheader{Set Implementation by Arrays}›
theory ArraySetImpl
imports 
  "../spec/SetSpec" 
  ArrayMapImpl 
  "../gen_algo/SetByMap" 
  "../gen_algo/SetGA"
begin
text_raw ‹\label{thy:ArraySetImpl}›

(*@impl Set
  @type ias
  @abbrv ias,is
  Sets of natural numbers implemented by arrays.
*)

subsection "Definitions"
type_synonym ias = "(unit) iam"

setup Locale_Code.open_block
interpretation ias_sbm: OSetByOMap iam_basic_ops by unfold_locales
setup Locale_Code.close_block
definition ias_ops :: "(nat,ias) oset_ops"
  where [icf_rec_def]:
  "ias_ops  ias_sbm.obasic.dflt_oops"

setup Locale_Code.open_block
interpretation ias: StdOSet ias_ops
  unfolding ias_ops_def by (rule ias_sbm.obasic.dflt_oops_impl)
interpretation ias: StdSet_no_invar ias_ops
  by unfold_locales (simp add: icf_rec_unf SetByMapDefs.invar_def)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "ias"

lemmas ias_it_to_it_map_code_unfold[code_unfold] = 
  it_to_it_map_fold'[OF pi_iam]
  it_to_it_map_fold'[OF pi_iam_rev]

lemma pi_ias[proper_it]: 
  "proper_it' ias.iteratei ias.iteratei"
  "proper_it' ias.iterateoi ias.iterateoi"
  "proper_it' ias.rev_iterateoi ias.rev_iterateoi"
  unfolding ias.iteratei_def[abs_def] ias.iterateoi_def[abs_def] 
    ias.rev_iterateoi_def[abs_def]
  apply (rule proper_it'I icf_proper_iteratorI)+
  done

interpretation 
  pi_ias: proper_it_loc ias.iteratei ias.iteratei +
  pi_ias_o: proper_it_loc ias.iterateoi ias.iterateoi +
  pi_ias_ro: proper_it_loc ias.rev_iterateoi ias.rev_iterateoi
  apply unfold_locales by (rule pi_ias)+

definition test_codegen where "test_codegen  (
  ias.empty,
  ias.memb,
  ias.ins,
  ias.delete,
  ias.list_it,
  ias.sng,
  ias.isEmpty,
  ias.isSng,
  ias.ball,
  ias.bex,
  ias.size,
  ias.size_abort,
  ias.union,
  ias.union_dj,
  ias.diff,
  ias.filter,
  ias.inter,
  ias.subset,
  ias.equal,
  ias.disjoint,
  ias.disjoint_witness,
  ias.sel,
  ias.to_list,
  ias.from_list,

  ias.ordered_list_it,
  ias.rev_list_it,
  ias.min, 
  ias.max, 
  ias.to_sorted_list,
  ias.to_rev_list
)"

export_code test_codegen checking SML

end

Theory SetStdImpl

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section "Standard Set Implementations"
theory SetStdImpl
imports 
  ListSetImpl 
  ListSetImpl_Invar 
  ListSetImpl_NotDist
  ListSetImpl_Sorted
  RBTSetImpl HashSet 
  TrieSetImpl 
  ArrayHashSet
  ArraySetImpl
begin
text_raw ‹\label{thy:SetStdImpl}›
text ‹
  This theory summarizes standard set implementations, namely list-sets RB-tree-sets, trie-sets and hashsets.
›

end

Theory Fifo

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Fifo Queue by Pair of Lists}›
theory Fifo
imports 
  "../gen_algo/ListGA"
  "../tools/Record_Intf"
  "../tools/Locale_Code"
begin
text_raw ‹\label{thy:Fifo}›

(* TODO: Move to Misc *)
lemma rev_tl_rev: "rev (tl (rev l)) = butlast l"
  by (induct l) auto


(*@impl List
  @type 'a fifo
  @abbrv fifo
  Fifo-Queues implemented by two stacks.
*)

text ‹
  A fifo-queue is implemented by a pair of two lists (stacks). 
  New elements are pushed on the first stack, and elements are popped from 
  the second stack. If the second stack is empty, the first stack is reversed
  and replaces the second stack.

  If list reversal is implemented efficiently (what is the case in Isabelle/HOL, 
  cf @{thm [source] List.rev_conv_fold})
  the amortized time per buffer operation is constant.

  Moreover, this fifo implementation also supports efficient push and pop operations.
›

subsection ‹Definitions›
type_synonym 'a fifo = "'a list × 'a list"

text "Abstraction of the fifo to a list. The next element to be got is at 
      the head of the list, and new elements are appended at the end of the
      list"
definition fifo_α :: "'a fifo  'a list" 
  where "fifo_α F == snd F @ rev (fst F)"

text "This fifo implementation has no invariants, any pair of lists is a 
  valid fifo"
definition [simp, intro!]: "fifo_invar x = True"


  ― ‹The empty fifo›
definition fifo_empty :: "unit  'a fifo" 
  where "fifo_empty == λ_::unit. ([],[])"

  ― ‹True, iff the fifo is empty›
definition fifo_isEmpty :: "'a fifo  bool" where "fifo_isEmpty F == F=([],[])"

definition fifo_size :: "'a fifo  nat" where 
  "fifo_size F  length (fst F) + length (snd F)"

  ― ‹Add an element to the fifo›
definition fifo_appendr :: "'a  'a fifo  'a fifo" 
  where "fifo_appendr a F == (a#fst F, snd F)"

definition fifo_appendl :: "'a  'a fifo  'a fifo"
  where "fifo_appendl x F == case F of (e,d)  (e,x#d)"

― ‹Get an element from the fifo›
definition fifo_remover :: "'a fifo  ('a fifo × 'a)" where 
  "fifo_remover F ==
    case fst F of
      (a#l)  ((l,snd F),a) |
      []  let rp=rev (snd F) in
        ((tl rp,[]),hd rp)"

definition fifo_removel :: "'a fifo  ('a × 'a fifo)" where 
  "fifo_removel F ==
    case snd F of
      (a#l)  (a, (fst F, l)) |
      []  let rp=rev (fst F) in
        (hd rp, ([], tl rp))
"

definition fifo_leftmost :: "'a fifo  'a" where
  "fifo_leftmost F  case F of (_,x#_)  x | (l,[])  last l"

definition fifo_rightmost :: "'a fifo  'a" where
  "fifo_rightmost F  case F of (x#_,_)  x | ([],l)  last l"

definition "fifo_iteratei F  foldli (fifo_α F)"
definition "fifo_rev_iteratei F  foldri (fifo_α F)"

definition "fifo_get F i  
  let
    l2 = length (snd F)
  in
    if i < l2 then 
      snd F!i 
    else
      (fst F)!(length (fst F) - Suc (i - l2))
  "

definition "fifo_set F i a  case F of (f1,f2) 
  let
    l2 = length f2
  in
    if i < l2 then 
      (f1,f2[i:=a])
    else
      (f1[length (fst F) - Suc (i - l2) := a],f2)"

subsection "Correctness"

lemma fifo_empty_impl: "list_empty fifo_α fifo_invar fifo_empty"
  apply (unfold_locales)
  by (auto simp add: fifo_α_def fifo_empty_def)

lemma fifo_isEmpty_impl: "list_isEmpty fifo_α fifo_invar fifo_isEmpty"
  apply (unfold_locales)
  by (case_tac s) (auto simp add: fifo_isEmpty_def fifo_α_def)

lemma fifo_size_impl: "list_size fifo_α fifo_invar fifo_size"
  apply unfold_locales
  by (auto simp add: fifo_size_def fifo_α_def)
  
lemma fifo_appendr_impl: "list_appendr fifo_α fifo_invar fifo_appendr"
  apply (unfold_locales)
  by (auto simp add: fifo_appendr_def fifo_α_def)

lemma fifo_appendl_impl: "list_appendl fifo_α fifo_invar fifo_appendl"
  apply (unfold_locales)
  by (auto simp add: fifo_appendl_def fifo_α_def)

lemma fifo_removel_impl: "list_removel fifo_α fifo_invar fifo_removel"
  apply (unfold_locales)
  apply (case_tac s)
  apply (case_tac b)
  apply (auto simp add: fifo_removel_def fifo_α_def Let_def) [2]
  apply (case_tac s)
  apply (case_tac "b")
  apply (auto simp add: fifo_removel_def fifo_α_def Let_def)
  done

lemma fifo_remover_impl: "list_remover fifo_α fifo_invar fifo_remover"
  apply (unfold_locales)
  unfolding fifo_remover_def fifo_α_def Let_def
  by (auto split: list.split simp: hd_rev rev_tl_rev butlast_append)

lemma fifo_leftmost_impl: "list_leftmost fifo_α fifo_invar fifo_leftmost"
  apply unfold_locales
  by (auto simp: fifo_leftmost_def fifo_α_def hd_rev split: list.split)

lemma fifo_rightmost_impl: "list_rightmost fifo_α fifo_invar fifo_rightmost"
  apply unfold_locales
  by (auto simp: fifo_rightmost_def fifo_α_def hd_rev split: list.split)

lemma fifo_get_impl: "list_get fifo_α fifo_invar fifo_get"
  apply unfold_locales
  apply (auto simp: fifo_α_def fifo_get_def Let_def nth_append rev_nth)
  done

lemma fifo_set_impl: "list_set fifo_α fifo_invar fifo_set"
  apply unfold_locales
  apply (auto simp: fifo_α_def fifo_set_def Let_def list_update_append
    rev_update)
  done

definition [icf_rec_def]: "fifo_ops  
  list_op_α = fifo_α,
  list_op_invar = fifo_invar,
  list_op_empty = fifo_empty,
  list_op_isEmpty = fifo_isEmpty,
  list_op_size = fifo_size,
  list_op_appendl = fifo_appendl,
  list_op_removel = fifo_removel,
  list_op_leftmost = fifo_leftmost,
  list_op_appendr = fifo_appendr,
  list_op_remover = fifo_remover,
  list_op_rightmost = fifo_rightmost,
  list_op_get = fifo_get,
  list_op_set = fifo_set
  "

setup Locale_Code.open_block
interpretation fifo: StdList fifo_ops
  apply (rule StdList.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule 
    fifo_empty_impl
    fifo_isEmpty_impl
    fifo_size_impl
    fifo_appendl_impl
    fifo_removel_impl
    fifo_leftmost_impl
    fifo_appendr_impl
    fifo_remover_impl
    fifo_rightmost_impl
    fifo_get_impl
    fifo_set_impl)+
  done
interpretation fifo: StdList_no_invar fifo_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup ICF_Tools.revert_abbrevs "fifo"

definition test_codegen where "test_codegen  
  (
    fifo.empty,
    fifo.isEmpty,
    fifo.size,
    fifo.appendl,
    fifo.removel,
    fifo.leftmost,
    fifo.appendr,
    fifo.remover,
    fifo.rightmost,
    fifo.get,
    fifo.set,
    fifo.iteratei,
    fifo.rev_iteratei
  )"

export_code test_codegen checking SML

end

Theory BinoPrioImpl

section ‹\isaheader{Implementation of Priority Queues by Binomial Heap}›

theory BinoPrioImpl
imports 
  "Binomial-Heaps.BinomialHeap" 
  "../spec/PrioSpec"
  "../tools/Record_Intf"
  "../tools/Locale_Code"
begin

(*@impl Prio
  @type ('a,'p::linorder) bino
  @abbrv bino
  Binomial heaps.
*)

type_synonym ('a,'b) bino = "('a,'b) BinomialHeap"

subsection "Definitions"
definition bino_α where "bino_α q  BinomialHeap.to_mset q"
definition bino_insert where "bino_insert  BinomialHeap.insert"
abbreviation (input) bino_invar :: "('a,'b) BinomialHeap  bool"
  where "bino_invar  λ_. True"
definition bino_find where "bino_find  BinomialHeap.findMin"
definition bino_delete where "bino_delete  BinomialHeap.deleteMin"
definition bino_meld where "bino_meld  BinomialHeap.meld"
definition bino_empty where "bino_empty  λ_::unit. BinomialHeap.empty"
definition bino_isEmpty where "bino_isEmpty = BinomialHeap.isEmpty"

definition [icf_rec_def]: "bino_ops == 
  prio_op_α = bino_α,
  prio_op_invar = bino_invar,
  prio_op_empty = bino_empty,
  prio_op_isEmpty = bino_isEmpty,
  prio_op_insert = bino_insert,
  prio_op_find = bino_find,
  prio_op_delete = bino_delete,
  prio_op_meld = bino_meld
"

lemmas bino_defs =
  bino_α_def
  bino_insert_def
  bino_find_def
  bino_delete_def
  bino_meld_def
  bino_empty_def
  bino_isEmpty_def

subsection "Correctness"

theorem bino_empty_impl: "prio_empty bino_α bino_invar bino_empty"
  by (unfold_locales, auto simp add: bino_defs)

theorem bino_isEmpty_impl: "prio_isEmpty bino_α bino_invar bino_isEmpty"
  by unfold_locales 
     (simp add: bino_defs BinomialHeap.isEmpty_correct BinomialHeap.empty_correct)

theorem bino_find_impl: "prio_find bino_α bino_invar bino_find"
  apply unfold_locales
  apply (simp add: bino_defs BinomialHeap.empty_correct BinomialHeap.findMin_correct)
  done

lemma bino_insert_impl: "prio_insert bino_α bino_invar bino_insert"
  apply(unfold_locales)
  apply(unfold bino_defs) 
  apply (simp_all add: BinomialHeap.insert_correct)
  done

lemma bino_meld_impl: "prio_meld bino_α bino_invar bino_meld"
  apply(unfold_locales)
  apply(unfold bino_defs)
  apply(simp_all add: BinomialHeap.meld_correct)
  done
      
lemma bino_delete_impl: 
  "prio_delete bino_α bino_invar bino_find bino_delete"
  apply intro_locales
  apply (rule bino_find_impl)
  apply(unfold_locales)
  apply(simp_all add: bino_defs BinomialHeap.empty_correct BinomialHeap.deleteMin_correct)
done 

setup Locale_Code.open_block
interpretation bino: StdPrio bino_ops
  apply (rule StdPrio.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule 
    bino_empty_impl
    bino_isEmpty_impl
    bino_find_impl
    bino_insert_impl
    bino_meld_impl
    bino_delete_impl
  )+
  done
interpretation bino: StdPrio_no_invar bino_ops
  apply unfold_locales
  apply (simp add: icf_rec_unf)
  done
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "bino"

definition test_codegen where "test_codegen = (
  bino.empty,
  bino.isEmpty,
  bino.find,
  bino.insert,
  bino.meld,
  bino.delete
)"

export_code test_codegen checking SML

end

Theory SkewPrioImpl

section ‹\isaheader{Implementation of Priority Queues by Skew Binomial Heaps}›

theory SkewPrioImpl
imports 
  "Binomial-Heaps.SkewBinomialHeap" 
  "../spec/PrioSpec"
  "../tools/Record_Intf"
  "../tools/Locale_Code"
begin

(*@impl Prio
  @type ('a,'p::linorder) skew
  @abbrv skew
  Priority queues by skew binomial heaps. 
*)

subsection "Definitions"
type_synonym ('a,'b) skew = "('a, 'b) SkewBinomialHeap"

definition skew_α where "skew_α q  SkewBinomialHeap.to_mset q"
definition skew_insert where "skew_insert  SkewBinomialHeap.insert"
abbreviation (input) skew_invar :: "('a, 'b) SkewBinomialHeap  bool" 
  where "skew_invar  λ_. True"
definition skew_find where "skew_find  SkewBinomialHeap.findMin"
definition skew_delete where "skew_delete  SkewBinomialHeap.deleteMin"
definition skew_meld where "skew_meld  SkewBinomialHeap.meld"
definition skew_empty where "skew_empty  λ_::unit. SkewBinomialHeap.empty"
definition skew_isEmpty where "skew_isEmpty = SkewBinomialHeap.isEmpty"

definition [icf_rec_def]: "skew_ops == 
  prio_op_α = skew_α,
  prio_op_invar = skew_invar,
  prio_op_empty = skew_empty,
  prio_op_isEmpty = skew_isEmpty,
  prio_op_insert = skew_insert,
  prio_op_find = skew_find,
  prio_op_delete = skew_delete,
  prio_op_meld = skew_meld
"

lemmas skew_defs =
  skew_α_def
  skew_insert_def
  skew_find_def
  skew_delete_def
  skew_meld_def
  skew_empty_def
  skew_isEmpty_def

subsection "Correctness"

theorem skew_empty_impl: "prio_empty skew_α skew_invar skew_empty"
  by (unfold_locales, auto simp add: skew_defs)

theorem skew_isEmpty_impl: "prio_isEmpty skew_α skew_invar skew_isEmpty"
  by unfold_locales 
     (simp add: skew_defs SkewBinomialHeap.isEmpty_correct SkewBinomialHeap.empty_correct)

theorem skew_find_impl: "prio_find skew_α skew_invar skew_find"
  apply unfold_locales
  apply (simp add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.findMin_correct)
  done

lemma skew_insert_impl: "prio_insert skew_α skew_invar skew_insert"
  apply(unfold_locales)
  apply(unfold skew_defs) 
  apply (simp_all add: SkewBinomialHeap.insert_correct)
  done

lemma skew_meld_impl: "prio_meld skew_α skew_invar skew_meld"
  apply(unfold_locales)
  apply(unfold skew_defs)
  apply(simp_all add: SkewBinomialHeap.meld_correct)
  done
      
lemma skew_delete_impl: 
  "prio_delete skew_α skew_invar skew_find skew_delete"
  apply intro_locales
  apply (rule skew_find_impl)
  apply(unfold_locales)
  apply(simp_all add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.deleteMin_correct)
done 

setup Locale_Code.open_block
interpretation skew: StdPrio skew_ops
  apply (rule StdPrio.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule 
    skew_empty_impl
    skew_isEmpty_impl
    skew_find_impl
    skew_insert_impl
    skew_meld_impl
    skew_delete_impl
  )+
  done
interpretation skew: StdPrio_no_invar skew_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

definition test_codegen where "test_codegen  (
  skew.empty,
  skew.isEmpty,
  skew.find,
  skew.insert,
  skew.meld,
  skew.delete
)"

export_code test_codegen checking SML

end

Theory FTAnnotatedListImpl

section ‹\isaheader{Implementation of Annotated Lists by 2-3 Finger Trees}›
theory FTAnnotatedListImpl
imports 
  "Finger-Trees.FingerTree" 
  "../tools/Locale_Code"
  "../tools/Record_Intf"
  "../spec/AnnotatedListSpec"
begin

(*@impl AnnotatedList
  @type ('a,'b::monoid_add) ft
  @abbrv ft
  Annotated lists implemented by 2-3 finger trees.
*)

type_synonym ('a,'b) ft = "('a,'b) FingerTree"
subsection "Definitions"

definition ft_α where
  "ft_α  FingerTree.toList"
abbreviation (input) ft_invar :: "('a,'b) FingerTree  bool" where 
  "ft_invar  λ_. True"
definition ft_empty where
  "ft_empty  λ_::unit. FingerTree.empty"
definition ft_isEmpty where
  "ft_isEmpty  FingerTree.isEmpty"
definition ft_count where
  "ft_count  FingerTree.count"
definition ft_consl where
  "ft_consl e a s = FingerTree.lcons (e,a) s"
definition ft_consr where
  "ft_consr s e a = FingerTree.rcons s (e,a)"
definition ft_head where
  "ft_head  FingerTree.head"
definition ft_tail where
  "ft_tail  FingerTree.tail"
definition ft_headR where
  "ft_headR  FingerTree.headR"
definition ft_tailR where
  "ft_tailR  FingerTree.tailR"
definition ft_foldl where
  "ft_foldl  FingerTree.foldl"
definition ft_foldr where
  "ft_foldr  FingerTree.foldr"
definition ft_app where
  "ft_app  FingerTree.app"
definition ft_annot where
  "ft_annot  FingerTree.annot"
definition ft_splits where 
  "ft_splits  FingerTree.splitTree"

lemmas ft_defs =
  ft_α_def
  ft_empty_def
  ft_isEmpty_def
  ft_count_def
  ft_consl_def
  ft_consr_def
  ft_head_def
  ft_tail_def
  ft_headR_def
  ft_tailR_def
  ft_foldl_def
  ft_foldr_def
  ft_app_def
  ft_annot_def
  ft_splits_def

lemma ft_empty_impl: "al_empty ft_α ft_invar ft_empty"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.empty_correct)
  done

lemma ft_consl_impl: "al_consl ft_α ft_invar ft_consl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.lcons_correct)
done

lemma ft_consr_impl: "al_consr ft_α ft_invar ft_consr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.rcons_correct)
done

lemma ft_isEmpty_impl: "al_isEmpty ft_α ft_invar ft_isEmpty" 
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.isEmpty_correct FingerTree.empty_correct)
  done

lemma ft_count_impl: "al_count ft_α ft_invar ft_count"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.count_correct)
  done

lemma ft_head_impl: "al_head ft_α ft_invar ft_head"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.head_correct FingerTree.empty_correct)
done

lemma ft_tail_impl: "al_tail ft_α ft_invar ft_tail"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tail_correct FingerTree.empty_correct)
done

lemma ft_headR_impl: "al_headR ft_α ft_invar ft_headR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.headR_correct FingerTree.empty_correct)
done

lemma ft_tailR_impl: "al_tailR ft_α ft_invar ft_tailR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tailR_correct FingerTree.empty_correct)
    done

lemma ft_foldl_impl: "al_foldl ft_α ft_invar ft_foldl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done 

lemma ft_foldr_impl: "al_foldr ft_α ft_invar ft_foldr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done 

lemma ft_foldl_cunfold[code_unfold]:
  "List.foldl f σ (ft_α t) = ft_foldl f σ t"
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done 

lemma ft_foldr_cunfold[code_unfold]:
  "List.foldr f (ft_α t) σ = ft_foldr f t σ"
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done 

lemma ft_app_impl: "al_app ft_α ft_invar ft_app"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.app_correct)
  done

lemma ft_annot_impl: "al_annot ft_α ft_invar ft_annot"
  apply unfold_locales 
  apply (auto simp add: ft_defs FingerTree.annot_correct)
  done

lemma ft_splits_impl: "al_splits ft_α ft_invar ft_splits"
  apply unfold_locales
  apply (unfold ft_defs)
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply (frule (3) FingerTree.splitTree_correct(1))
  apply (frule (3) FingerTree.splitTree_correct(2))
  apply (frule (3) FingerTree.splitTree_correct(3))
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply simp
  done

subsubsection "Record Based Implementation"

definition [icf_rec_def]: "ft_ops = 
  alist_op_α = ft_α,
  alist_op_invar = ft_invar,
  alist_op_empty = ft_empty,
  alist_op_isEmpty = ft_isEmpty,
  alist_op_count = ft_count,
  alist_op_consl = ft_consl,
  alist_op_consr = ft_consr,
  alist_op_head = ft_head,
  alist_op_tail = ft_tail,
  alist_op_headR = ft_headR,
  alist_op_tailR = ft_tailR,
  alist_op_app = ft_app,
  alist_op_annot = ft_annot,
  alist_op_splits = ft_splits
  "

setup Locale_Code.open_block
interpretation ft: StdAL ft_ops
  apply (rule StdAL.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule 
    ft_empty_impl
    ft_consl_impl
    ft_consr_impl
    ft_isEmpty_impl
    ft_count_impl
    ft_head_impl
    ft_tail_impl
    ft_headR_impl
    ft_tailR_impl
    ft_foldl_impl
    ft_foldr_impl
    ft_app_impl
    ft_annot_impl
    ft_splits_impl
  )+
  done
interpretation ft: StdAL_no_invar ft_ops
  by (unfold_locales) (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "ft"


definition "test_codegen  (
  ft.empty,
  ft.isEmpty,
  ft.count,
  ft.consl,
  ft.consr,
  ft.head,
  ft.tail,
  ft.headR,
  ft.tailR,
  ft.app,
  ft.annot,
  ft.splits,
  ft.foldl,
  ft.foldr
)"

export_code test_codegen checking SML

end

Theory FTPrioImpl

section ‹\isaheader{Implementation of Priority Queues by Finger Trees}›
theory FTPrioImpl
imports FTAnnotatedListImpl 
  "../gen_algo/PrioByAnnotatedList"
begin
(*@impl Prio
  @type ('a,'p::linorder) alprioi
  @abbrv alprioi
  Priority queues based on 2-3 finger trees.
*)

type_synonym ('a,'p) alprioi = "(unit, ('a, 'p) Prio) FingerTree"

setup Locale_Code.open_block
interpretation alprio_ga: alprio ft_ops by unfold_locales
setup Locale_Code.close_block

definition [icf_rec_def]: "alprioi_ops  alprio_ga.alprio_ops"

setup Locale_Code.open_block
interpretation alprioi: StdPrio alprioi_ops
  unfolding alprioi_ops_def
  by (rule alprio_ga.alprio_ops_impl)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "alprioi"


definition test_codegen where "test_codegen  (
  alprioi.empty,
  alprioi.isEmpty,
  alprioi.insert,
  alprioi.find,
  alprioi.delete,
  alprioi.meld
)"

export_code test_codegen checking SML

end

Theory FTPrioUniqueImpl

section ‹\isaheader{Implementation of Unique Priority Queues by Finger Trees}›
theory FTPrioUniqueImpl
imports 
  FTAnnotatedListImpl 
  "../gen_algo/PrioUniqueByAnnotatedList"
begin
(*@impl PrioUnique
  @type ('a::linorder,'p::linorder) aluprioi
  @abbrv aluprioi
  Unique priority queues based on 2-3 finger trees.
*)

subsection "Definitions"

type_synonym ('a,'b) aluprioi = "(unit, ('a, 'b) LP) FingerTree"

setup Locale_Code.open_block
interpretation aluprio_ga: aluprio ft_ops by unfold_locales
setup Locale_Code.close_block

definition [icf_rec_def]: "aluprioi_ops  aluprio_ga.aluprio_ops"

setup Locale_Code.open_block
interpretation aluprioi: StdUprio aluprioi_ops
  unfolding aluprioi_ops_def
  by (rule aluprio_ga.aluprio_ops_impl)
setup Locale_Code.close_block

setup ICF_Tools.revert_abbrevs "aluprioi"

definition test_codegen where "test_codegen  (
  aluprioi.empty,
  aluprioi.isEmpty,
  aluprioi.insert,
  aluprioi.pop,
  aluprioi.prio
)"

export_code test_codegen checking SML

end

Theory ICF_Impl

section ‹All ICF Implementations›
theory ICF_Impl
imports
  (*"../../Refine_Monadic/Refine_Monadic"*)
(* Interfaces *)
  "spec/SetSpec"
  "spec/MapSpec"
  "spec/ListSpec"
  "spec/AnnotatedListSpec"
  "spec/PrioSpec"
  "spec/PrioUniqueSpec"
(* Generic Algorithms *)
  "gen_algo/Algos"
  "gen_algo/SetIndex"
(* Implementations *)
  "impl/SetStdImpl"
  "impl/MapStdImpl"
  "impl/Fifo"
  "impl/BinoPrioImpl"
  "impl/SkewPrioImpl"
  "impl/FTAnnotatedListImpl"
  "impl/FTPrioImpl"
  "impl/FTPrioUniqueImpl"
begin


end

Theory ICF_Refine_Monadic

section ‹\isaheader{Refine-Monadci setup for ICF}›
theory ICF_Refine_Monadic
imports ICF_Impl
begin
text ‹
  This theory sets up some lemmas that automate refinement proofs using
  the Isabelle Collection Framework (ICF).
›

subsection ‹General Setup›

lemma (in set) drh[refine_dref_RELATES]: 
  "RELATES (build_rel α invar)" by (simp add: RELATES_def)
lemma (in map) drh[refine_dref_RELATES]: 
  "RELATES (build_rel α invar)" by (simp add: RELATES_def)

lemma (in uprio) drh[refine_dref_RELATES]: "RELATES (build_rel α invar)" 
  by (simp add: RELATES_def)
lemma (in prio) drh[refine_dref_RELATES]: "RELATES (build_rel α invar)" 
  by (simp add: RELATES_def)


lemmas (in StdSet) [refine_hsimp] = correct
lemmas (in StdMap) [refine_hsimp] = correct

lemma (in set_sel') pick_ref[refine_hsimp]:
  " invar s; α s  {}  the (sel' s (λ_. True))  α s"
  by (auto elim!: sel'E)

(*text {* Wrapper to prevent higher-order unification problems *}
definition [simp, code_unfold]: "IT_tag x ≡ x"

lemma (in set_iteratei) it_is_iterator[refine_transfer]:
  "invar s ⟹ set_iterator (IT_tag iteratei s) (α s)"
  unfolding IT_tag_def by (rule iteratei_rule)

lemma (in map_iteratei) it_is_iterator[refine_transfer]:
  "invar m ⟹ set_iterator (IT_tag iteratei m) (map_to_set (α m))"
  unfolding IT_tag_def by (rule iteratei_rule)
*)

text ‹
  This definition is handy to be used on the abstract level.
›
definition "prio_pop_min q  do {
    ASSERT (dom q  {});
    SPEC (λ(e,w,q'). 
      q'=q(e:=None)  
      q e = Some w  
      ( e' w'. q e' = Some w'  ww')
    )
  }"

lemma (in uprio_pop) prio_pop_min_refine[refine]:
  "(q,q')build_rel α invar  RETURN (pop q) 
      (Id,Id,br α invarprod_relprod_rel) (prio_pop_min q')"
  unfolding prio_pop_min_def
  apply refine_rcg
  apply (clarsimp simp: prod_rel_def br_def)
  apply (erule (1) popE)
  apply (rule pw_leI)
  apply (auto simp: refine_pw_simps intro: ranI)
  done


subsection "Iterators"
lemmas (in poly_map_iteratei) [refine_transfer] = iteratei_correct
lemmas (in poly_map_iterateoi) [refine_transfer] = iterateoi_correct
lemmas (in map_no_invar) [refine_transfer] = invar

lemmas (in poly_set_iteratei) [refine_transfer] = iteratei_correct
lemmas (in poly_set_iterateoi) [refine_transfer] = iterateoi_correct
lemmas (in set_no_invar) [refine_transfer] = invar

lemma (in poly_set_iteratei) dres_ne_bot_iterate[refine_transfer]:
  assumes A: "x s. f x s  dSUCCEED"
  shows "iteratei r c (λx s. dbind s (f x)) (dRETURN s)  dSUCCEED"
  unfolding iteratei_def it_to_list_def it_to_it_def
  apply (rule dres_foldli_ne_bot)
  by (simp_all add: A)
lemma (in poly_set_iterateoi) dres_ne_bot_iterateo[refine_transfer]:
  assumes A: "x s. f x s  dSUCCEED"
  shows "iterateoi r c (λx s. dbind s (f x)) (dRETURN s)  dSUCCEED"
  unfolding iterateoi_def it_to_list_def it_to_it_def
  apply (rule dres_foldli_ne_bot)
  by (simp_all add: A)

lemma (in poly_map_iteratei) dres_ne_bot_map_iterate[refine_transfer]:
  assumes A: "x s. f x s  dSUCCEED"
  shows "iteratei r c (λx s. dbind s (f x)) (dRETURN s)  dSUCCEED"
  unfolding iteratei_def it_to_list_def it_to_it_def
  apply (rule dres_foldli_ne_bot)
  by (simp_all add: A)
lemma (in poly_set_iterateoi) dres_ne_bot_map_iterateo[refine_transfer]:
  assumes A: "x s. f x s  dSUCCEED"
  shows "iterateoi r c (λx s. dbind s (f x)) (dRETURN s)  dSUCCEED"
  unfolding iterateoi_def it_to_list_def it_to_it_def
  apply (rule dres_foldli_ne_bot)
  by (simp_all add: A)





subsection "Alternative FOREACH-transfer"
text ‹Required for manual refinements›
lemma transfer_FOREACHoci_plain[refine_transfer]:
  assumes A: "set_iterator_genord iterate s ordR"
  assumes R: "x σ. RETURN (fi x σ)  f x σ"
  shows "RETURN (iterate c fi σ)  FOREACHoci ordR I s c f σ"
proof -
  from A obtain l where [simp]:
    "distinct l" 
    "s = set l" 
    "sorted_wrt ordR l"
    "iterate = foldli l" 
    unfolding set_iterator_genord_def by blast
  
  have "RETURN (foldli l c fi σ)  nfoldli l c f σ"
    by (rule nfoldli_transfer_plain[OF R])
  also have " = do { l  RETURN l; nfoldli l c f σ }" by simp
  also have "  FOREACHoci ordR I s c f σ"
    apply (rule refine_IdD)
    unfolding FOREACHoci_def
    apply refine_rcg
    apply simp
    apply simp
    apply (rule nfoldli_while)
    done
  finally show ?thesis by simp
qed

lemma transfer_FOREACHoi_plain[refine_transfer]:
  assumes A: "set_iterator_genord iterate s ordR"
  assumes R: "x σ. RETURN (fi x σ)  f x σ"
  shows "RETURN (iterate (λ_. True) fi σ)  FOREACHoi ordR I s f σ"
  using assms unfolding FOREACHoi_def by (rule transfer_FOREACHoci_plain)

lemma transfer_FOREACHci_plain[refine_transfer]:
  assumes A: "set_iterator iterate s"
  assumes R: "x σ. RETURN (fi x σ)  f x σ"
  shows "RETURN (iterate c fi σ)  FOREACHci I s c f σ"
  using assms unfolding FOREACHci_def set_iterator_def
  by (rule transfer_FOREACHoci_plain)

lemma transfer_FOREACHi_plain[refine_transfer]:
  assumes A: "set_iterator iterate s"
  assumes R: "x σ. RETURN (fi x σ)  f x σ"
  shows "RETURN (iterate (λ_. True) fi σ)  FOREACHi I s f σ"
  using assms unfolding FOREACHi_def
  by (rule transfer_FOREACHci_plain)

lemma transfer_FOREACHc_plain[refine_transfer]:
  assumes A: "set_iterator iterate s"
  assumes R: "x σ. RETURN (fi x σ)  f x σ"
  shows "RETURN (iterate c fi σ)  FOREACHc s c f σ"
  using assms unfolding FOREACHc_def
  by (rule transfer_FOREACHci_plain)

lemma transfer_FOREACH_plain[refine_transfer]:
  assumes A: "set_iterator iterate s"
  assumes R: "x σ. RETURN (fi x σ)  f x σ"
  shows "RETURN (iterate (λ_. True) fi σ)  FOREACH s f σ"
  using assms unfolding FOREACH_def
  by (rule transfer_FOREACHc_plain)

abbreviation "dres_it iterate c (fi::'a  'b  'b dres) σ  
  iterate (case_dres False False c) (λx s. sfi x) (dRETURN σ)"

lemma transfer_FOREACHoci_nres[refine_transfer]:
  assumes A: "set_iterator_genord iterate s ordR"
  assumes R: "x σ. nres_of (fi x σ)  f x σ"
  shows "nres_of (dres_it iterate c fi σ)  FOREACHoci ordR I s c f σ"
proof -
  from A obtain l where [simp]:
    "distinct l" 
    "s = set l" 
    "sorted_wrt ordR l"
    "iterate = foldli l" 
    unfolding set_iterator_genord_def by blast
  
  have "nres_of (dres_it (foldli l) c fi σ)  nfoldli l c f σ"
    by (rule nfoldli_transfer_dres[OF R])
  also have " = do { l  RETURN l; nfoldli l c f σ }" by simp
  also have "  FOREACHoci ordR I s c f σ"
    apply (rule refine_IdD)
    unfolding FOREACHoci_def
    apply refine_rcg
    apply simp
    apply simp
    apply (rule nfoldli_while)
    done
  finally show ?thesis by simp
qed

lemma transfer_FOREACHoi_nres[refine_transfer]:
  assumes A: "set_iterator_genord iterate s ordR"
  assumes R: "x σ. nres_of (fi x σ)  f x σ"
  shows "nres_of (dres_it iterate (λ_. True) fi σ)  FOREACHoi ordR I s f σ"
  using assms unfolding FOREACHoi_def by (rule transfer_FOREACHoci_nres)

lemma transfer_FOREACHci_nres[refine_transfer]:
  assumes A: "set_iterator iterate s"
  assumes R: "x σ. nres_of (fi x σ)  f x σ"
  shows "nres_of (dres_it iterate c fi σ)  FOREACHci I s c f σ"
  using assms unfolding FOREACHci_def set_iterator_def
  by (rule transfer_FOREACHoci_nres)

lemma transfer_FOREACHi_nres[refine_transfer]:
  assumes A: "set_iterator iterate s"
  assumes R: "x σ. nres_of (fi x σ)  f x σ"
  shows "nres_of (dres_it iterate (λ_. True) fi σ)  FOREACHi I s f σ"
  using assms unfolding FOREACHi_def
  by (rule transfer_FOREACHci_nres)

lemma transfer_FOREACHc_nres[refine_transfer]:
  assumes A: "set_iterator iterate s"
  assumes R: "x σ. nres_of (fi x σ)  f x σ"
  shows "nres_of (dres_it iterate c fi σ)  FOREACHc s c f σ"
  using assms unfolding FOREACHc_def
  by (rule transfer_FOREACHci_nres)

lemma transfer_FOREACH_nres[refine_transfer]:
  assumes A: "set_iterator iterate s"
  assumes R: "x σ. nres_of (fi x σ)  f x σ"
  shows "nres_of (dres_it iterate (λ_. True) fi σ)  FOREACH s f σ"
  using assms unfolding FOREACH_def
  by (rule transfer_FOREACHc_nres)


(*
lemma dres_ne_bot_iterate[refine_transfer]:
  assumes B: "set_iterator (IT_tag it r) S"
  assumes A: "⋀x s. f x s ≠ dSUCCEED"
  shows "IT_tag it r c (λx s. dbind s (f x)) (dRETURN s) ≠ dSUCCEED"
  apply (rule_tac I="λ_ s. s≠dSUCCEED" in set_iterator_rule_P[OF B])
  apply (rule dres_ne_bot_basic A | assumption)+
  done
*)

(*
subsubsection {* Monotonicity for Iterators *}

lemma it_mono_aux:
  assumes COND: "⋀σ σ'. σ≤σ' ⟹ c σ ≠ c σ' ⟹ σ=bot ∨ σ'=top "
  assumes STRICT: "⋀x. f x bot = bot" "⋀x. f' x top = top"
  assumes B: "σ≤σ'"
  assumes A: "⋀a x x'. x≤x' ⟹ f a x ≤ f' a x'"
  shows "foldli l c f σ ≤ foldli l c f' σ'"
proof -
  { fix l 
    have "foldli l c f bot = bot" by (induct l) (auto simp: STRICT)
  } note [simp] = this
  { fix l 
    have "foldli l c f' top = top" by (induct l) (auto simp: STRICT)
  } note [simp] = this

  show ?thesis
    using B
    apply (induct l arbitrary: σ σ')
    apply simp_all
    apply (metis assms foldli_not_cond)
    done
qed


lemma it_mono_aux_dres':
  assumes STRICT: "⋀x. f x bot = bot" "⋀x. f' x top = top"
  assumes A: "⋀a x x'. x≤x' ⟹ f a x ≤ f' a x'"
  shows "foldli l (case_dres True True c) f σ 
    ≤ foldli l (case_dres True True c) f' σ"
  apply (rule it_mono_aux)
  apply (simp_all split: dres.split_asm add: STRICT A)
  done

lemma it_mono_aux_dres:
  assumes A: "⋀a x. f a x ≤ f' a x"
  shows "foldli l (case_dres True True c) (λx s. dbind s (f x)) σ 
    ≤ foldli l (case_dres True True c) (λx s. dbind s (f' x)) σ"
  apply (rule it_mono_aux_dres')
  apply (simp_all)
  apply (rule dbind_mono)
  apply (simp_all add: A)
  done
  
lemma iteratei_mono':
  assumes L: "set_iteratei α invar it"
  assumes STRICT: "⋀x. f x bot = bot" "⋀x. f' x top = top"
  assumes A: "⋀a x x'. x≤x' ⟹ f a x ≤ f' a x'"
  assumes I: "invar s"
  shows "IT_tag it s (case_dres True True c) f σ 
    ≤ IT_tag it s (case_dres True True c) f' σ"
  proof -
    from set_iteratei.iteratei_rule[OF L, OF I, unfolded set_iterator_foldli_conv]
    obtain l0 where l0_props: "distinct l0" "α s = set l0" "it s = foldli l0" by blast
 
    from it_mono_aux_dres' [of f f' l0 c σ]
    show ?thesis
      unfolding IT_tag_def l0_props(3)
      by (simp add: STRICT A)
  qed

lemma iteratei_mono:
  assumes L: "set_iteratei α invar it"
  assumes A: "⋀a x. f a x ≤ f' a x"
  assumes I: "invar s"
  shows "IT_tag it s (case_dres True True c) (λx s. dbind s (f x)) σ 
    ≤ IT_tag it s (case_dres True True c) (λx s. dbind s (f' x)) σ"
 proof -
    from set_iteratei.iteratei_rule[OF L, OF I, unfolded set_iterator_foldli_conv]
    obtain l0 where l0_props: "distinct l0" "α s = set l0" "it s = foldli l0" by blast
 
    from it_mono_aux_dres [of f f' l0 c σ]
    show ?thesis
      unfolding IT_tag_def l0_props(3)
      by (simp add: A)
  qed

lemmas [refine_mono] = iteratei_mono[OF ls_iteratei_impl]
lemmas [refine_mono] = iteratei_mono[OF lsi_iteratei_impl]
lemmas [refine_mono] = iteratei_mono[OF rs_iteratei_impl]
lemmas [refine_mono] = iteratei_mono[OF ahs_iteratei_impl]
lemmas [refine_mono] = iteratei_mono[OF ias_iteratei_impl]
lemmas [refine_mono] = iteratei_mono[OF ts_iteratei_impl]
*)
(* Do not require the invariant for lsi_iteratei. 

This is kind of a hack -- the real fix comes with the new Collection/Refinement-Framework. *)
(*
lemma dres_ne_bot_iterate_lsi[refine_transfer]:
  fixes s :: "'a"
  assumes A: "⋀x s. f x s ≠ dSUCCEED"
  shows "IT_tag lsi_iteratei r c (λx s. dbind s (f x)) (dRETURN s) ≠ dSUCCEED"
proof -
  {
    fix l and s :: "'a dres"
    assume "s≠dSUCCEED" 
    hence "foldli l c (λx s. s⤜f x) s ≠ dSUCCEED"
      apply (induct l arbitrary: s)
      using A
      apply simp_all
      apply (intro impI)
      apply (metis dres_ne_bot_basic)
      done
  } note R=this
  with A show ?thesis
    unfolding lsi_iteratei_def
    by simp
qed


lemma iteratei_mono_lsi[refine_mono]:
  assumes A: "⋀a x. f a x ≤ f' a x"
  shows "IT_tag lsi_iteratei s (case_dres True True c) (λx s. dbind s (f x)) σ 
    ≤ IT_tag lsi_iteratei s (case_dres True True c) (λx s. dbind s (f' x)) σ"
 proof -
    from it_mono_aux_dres [of f f' s c σ]
    show ?thesis
      unfolding IT_tag_def lsi_iteratei_def
      by (simp add: A)
 qed
*)
end

Theory ICF_Autoref

section ‹ICF-setup for Automatic Refinement›
theory ICF_Autoref
imports 
  ICF_Refine_Monadic 
  "../GenCF/Intf/Intf_Set"
  "../GenCF/Intf/Intf_Map"
begin

subsection ‹Unique Priority Queue›
consts i_prio :: "interface  interface  interface"
definition [simp]: "op_uprio_empty  Map.empty"
definition [simp]: "op_uprio_is_empty x  x = Map.empty"
definition [simp]: "op_uprio_insert s e a  s(e  a)"
definition op_uprio_prio :: "('e'a)'e'a"
  where [simp]: "op_uprio_prio s e  s e"

(* FIXME: Tune id-(phase) such that it can distinguish those patterns!
  For now: Only include this patterns on demand!
*)
context begin interpretation autoref_syn .

lemma uprio_pats:
  fixes s :: "'e'a"
  shows
  "Map.empty::'e'a  op_uprio_empty"
  "s e  op_uprio_prio$s$e"
  "s(ea)  op_uprio_insert$s$e$a"

  "dom s = {}  op_uprio_is_empty$s"
  "{} = dom s  op_uprio_is_empty$s"
  "s=Map.empty  op_uprio_is_empty$s"
  "Map.empty=s  op_uprio_is_empty$s"
  by (auto intro!: eq_reflection)

end

term prio_pop_min

lemma [autoref_itype]:
  "op_uprio_empty ::i Ie,Iaii_prio"
  "op_uprio_prio ::i Ie,Iaii_prio i Ie i Iaii_option"
  "op_uprio_is_empty ::i Ie,Iaii_prio i i_bool"
  "op_uprio_insert ::i Ie,Iaii_prio i Ie i Ia i Ie,Iaii_prio"
  "prio_pop_min ::i Ie,Iaii_prio i Ie,Ia,Ie,Iaii_prioii_prodii_prodii_nres"
  by simp_all

context uprio begin
  definition rel_def_internal: 
    "Re Ra. rel Re Ra  br α invar O (Re  Ra option_rel)"
  lemma rel_def:
    "Re Ra. Re,Rarel  br α invar O (Re  Ra option_rel)" 
    by (simp add: rel_def_internal relAPP_def)
    
  lemma rel_id[simp]: "Id,Idrel = br α invar" 
    by (simp add: rel_def)

  lemma rel_sv[relator_props]: 
    "Re Ra. Range Re = UNIV; single_valued Ra  single_valued (Re,Rarel)"
    unfolding rel_def by tagged_solver

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_prio]
end


lemma (in uprio) rel_alt: "Id,Rvrel = 
  { (c,a). x. (α c x,a x)Rvoption_rel  invar c }"
  by (auto simp: rel_def br_def dest: fun_relD)

lemma (in uprio_empty) autoref_empty[autoref_rules]:
  "Re Ra. PREFER_id Re  (empty (),op_uprio_empty)Re,Rarel"
  by (auto simp: empty_correct rel_alt)

lemma (in uprio_isEmpty) autoref_is_empty[autoref_rules]:
  "Re Ra. PREFER_id Re  (isEmpty,op_uprio_is_empty)Re,Rarelbool_rel"
  by (auto simp: isEmpty_correct rel_alt intro!: ext)

lemma (in uprio_prio) autoref_prio[autoref_rules]:
  "Re Ra. PREFER_id Re  (prio,op_uprio_prio)Re,RarelReRaoption_rel"
  by (auto simp: prio_correct rel_alt intro!: ext)

lemma (in uprio_insert) autoref_insert[autoref_rules]:
  "Re Ra. PREFER_id Re  (insert,op_uprio_insert)Re,RarelReRaRe,Rarel"
  by (auto simp: insert_correct rel_alt intro!: ext)

lemma (in uprio_pop) autoref_prio_pop_min[autoref_rules]:
  "Re Ra. PREFER_id Re; PREFER_id Ra  
   (λs. RETURN (pop s),prio_pop_min)Re,RarelRe,Ra,Re,Rarelprod_relprod_relnres_rel"
  apply simp
  apply (intro fun_relI nres_relI)
  by (rule prio_pop_min_refine)




context set begin
  definition rel_def_internal: "rel R  br α invar O Rset_rel"
  lemma rel_def: "Rrel  br α invar O Rset_rel" 
    by (simp add: rel_def_internal relAPP_def)
    
  lemma rel_id[simp]: "Idrel = br α invar" by (simp add: rel_def)

  lemma rel_sv[relator_props]: "single_valued R  single_valued (Rrel)"
    unfolding rel_def by tagged_solver

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_set]

end

context map begin
  definition rel_def_internal: 
    "rel Rk Rv  br α invar O (Rk  Rv option_rel)"
  lemma rel_def: 
    "Rk,Rvrel  br α invar O (Rk  Rv option_rel)" 
    by (simp add: rel_def_internal relAPP_def)
    
  lemma rel_id[simp]: "Id,Idrel = br α invar" 
    by (simp add: rel_def)

  lemma rel_sv[relator_props]: 
    "Range Rk = UNIV; single_valued Rv  single_valued (Rk,Rvrel)"
    unfolding rel_def 
    by (tagged_solver (trace))

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_map]

end


(*
context list begin
  definition rel_def_internal: 
    "rel R ≡ br α invar O R"
  lemma rel_def: "⟨R⟩rel ≡ br α invar O R" 
    by (simp add: rel_def_internal relAPP_def)
    
  lemma rel_id[simp]: "⟨Id⟩rel = br α invar" 
    by (simp add: rel_def)

  lemma rel_sv[relator_props]: "single_valued R ⟹ single_valued (⟨R⟩rel)"
    unfolding rel_def by refine_post
end

context al begin
  definition rel_def_internal: 
    "rel Re Ra ≡ br α invar O ⟨⟨Re,Ra⟩ prod_rel⟩list_rel"
  lemma rel_def: 
    "⟨Re,Ra⟩rel ≡ br α invar O ⟨⟨Re,Ra⟩ prod_rel⟩list_rel" 
    by (simp add: rel_def_internal relAPP_def)
    
  lemma rel_id[simp]: "⟨Id,Id⟩rel = br α invar" 
    by (simp add: rel_def)

  lemma rel_sv[relator_props]: 
    "⟦single_valued Re; single_valued Ra⟧ ⟹ single_valued (⟨Re,Ra⟩rel)"
    unfolding rel_def by refine_post

end

context prio begin
  (* TODO: Fix that to use multiset_rel! *)
  definition rel_def[simp]: "rel ≡ br α invar"
  lemma rel_sv: "single_valued rel" unfolding rel_def by refine_post
end

context uprio begin
  definition rel_def_internal: 
    "rel Re Ra ≡ br α invar O (Re → ⟨Ra⟩ option_rel)"
  lemma rel_def:
    "⟨Re,Ra⟩rel ≡ br α invar O (Re → ⟨Ra⟩ option_rel)" 
    by (simp add: rel_def_internal relAPP_def)
    
  lemma rel_id[simp]: "⟨Id,Id⟩rel = br α invar" 
    by (simp add: rel_def)

  lemma rel_sv[relator_props]: 
    "⟦Range Re = UNIV; single_valued Ra⟧ ⟹ single_valued (⟨Re,Ra⟩rel)"
    unfolding rel_def by refine_post

end
*)


setup Revert_Abbrev.revert_abbrev "Autoref_Binding_ICF.*.rel"




(* TODO: Move *)
lemma Collect_x_x_pairs_rel_image[simp]: "{p. x. p = (x, x)}``x = x" 
    by auto


subsection "Set"

lemma (in set_empty) empty_autoref[autoref_rules]: 
  "PREFER_id Rk  (empty (), {})  Rkrel"
  by (simp add: br_def empty_correct)

lemma (in set_memb) memb_autoref[autoref_rules]: 
  "PREFER_id Rk  (memb,(∈))RkRkrelId"
  apply simp
  by (auto simp add: memb_correct br_def)

lemma (in set_ins) ins_autoref[autoref_rules]: 
  "PREFER_id Rk  (ins,Set.insert)RkRkrelRkrel"
  by simp (auto simp add: ins_correct br_def)

context set_ins_dj begin
context begin interpretation autoref_syn .
lemma ins_dj_autoref[autoref_rules]: 
  assumes "SIDE_PRECOND_OPT (x's')"
  assumes "PREFER_id Rk"
  assumes "(x,x')Rk"
  assumes "(s,s')Rkrel"
  shows "(ins_dj x s,(OP Set.insert ::: Rk  Rkrel  Rkrel)$x'$s')Rkrel"
  using assms 
  apply simp
  apply (auto simp add: ins_dj_correct br_def)
  done
end
end

lemma (in set_delete) delete_autoref[autoref_rules]: 
  "PREFER_id Rk  (delete,op_set_delete)RkRkrelRkrel"
  by simp (auto simp add: delete_correct op_set_delete_def br_def)
 
lemma (in set_isEmpty) isEmpty_autoref[autoref_rules]: 
  "PREFER_id Rk  (isEmpty,op_set_isEmpty)  RkrelId"
  apply (simp add: br_def)
  apply (fastforce simp: isEmpty_correct)
  done

lemma (in set_isSng) isSng_autoref[autoref_rules]: 
  "PREFER_id Rk  (isSng,op_set_isSng)  RkrelId"
  by simp
    (auto simp add: isSng_correct op_set_isSng_def br_def card_Suc_eq)

lemma (in set_ball) ball_autoref[autoref_rules]: 
  "PREFER_id Rk  (ball,Set.Ball)  Rkrel(RkId)Id"
  by simp (auto simp add: ball_correct fun_rel_def br_def)

lemma (in set_bex) bex_autoref[autoref_rules]: 
  "PREFER_id Rk  (bex,Set.Bex)  Rkrel(RkId)Id"
  apply simp
  apply (auto simp: bex_correct fun_rel_def br_def intro!: ext)
  done

lemma (in set_size) size_autoref[autoref_rules]: 
  "PREFER_id Rk  (size,card)  Rkrel  Id"
  by simp (auto simp add: size_correct br_def)

lemma (in set_size_abort) size_abort_autoref[autoref_rules]: 
  "PREFER_id Rk  (size_abort,op_set_size_abort)  Id  Rkrel  Id"
  by simp
    (auto simp add: size_abort_correct op_set_size_abort_def br_def)

lemma (in set_union) union_autoref[autoref_rules]: 
  "PREFER_id Rk  (union,(∪))Rks1.relRks2.relRks3.rel"
  by simp (auto simp add: union_correct br_def)

context set_union_dj begin
context begin interpretation autoref_syn .

lemma union_dj_autoref[autoref_rules]:
  assumes "PREFER_id Rk"
  assumes "SIDE_PRECOND_OPT (a'b'={})"
  assumes "(a,a')Rks1.rel"
  assumes "(b,b')Rks2.rel"
  shows "(union_dj a b,(OP (∪) ::: Rks1.rel  Rks2.rel  Rks3.rel)$a'$b')
    Rks3.rel"
  using assms 
  by simp (auto simp: union_dj_correct br_def)
end 
end

lemma (in set_diff) diff_autoref[autoref_rules]: 
  "PREFER_id Rk  (diff,(-))Rks1.relRks2.relRks1.rel"
  by simp (auto simp add: diff_correct br_def)

lemma (in set_filter) filter_autoref[autoref_rules]: 
  "PREFER_id Rk  (filter,op_set_filter)(Rk  Id)  Rks1.relRks2.rel"
  by simp (auto simp add: filter_correct op_set_filter_def fun_rel_def 
    br_def)

lemma (in set_inter) inter_autoref[autoref_rules]: 
  "PREFER_id Rk  (inter,(∩))Rks1.relRks2.relRks3.rel"
  by simp (auto simp add: inter_correct br_def)

lemma (in set_subset) subset_autoref[autoref_rules]: 
  "PREFER_id Rk  (subset,(⊆))Rks1.relRks2.relId"
  by simp (auto simp add: subset_correct br_def)

lemma (in set_equal) equal_autoref[autoref_rules]: 
  "PREFER_id Rk  (equal,(=))Rks1.relRks2.relId"
  by simp (auto simp add: equal_correct br_def)

lemma (in set_disjoint) disjoint_autoref[autoref_rules]: 
  "PREFER_id Rk  (disjoint,op_set_disjoint)Rks1.relRks2.relId"
  by simp (auto simp add: disjoint_correct op_set_disjoint_def br_def)

lemma (in list_to_set) to_set_autoref[autoref_rules]: 
  "PREFER_id Rk  (to_set,set)Rklist_rel  Rkrel"
  apply simp
  apply (auto simp add: to_set_correct br_def)
  done

context set_sel' begin
context begin interpretation autoref_syn .

lemma autoref_op_set_pick[autoref_rules]: 
  assumes "SIDE_PRECOND (s'{})"
  assumes "PREFER_id Rk"
  assumes "(s,s')Rkrel"
  shows "(RETURN (the (sel' s (λ_. True))), 
          (OP op_set_pick ::: Rkrel  Rknres_rel) $ s')
     Rknres_rel"
  using assms
  apply (clarsimp simp add: br_def nres_rel_def ex_in_conv[symmetric])
  apply (erule (1) sel'E[OF _ _ TrueI])
  apply (auto intro: RES_refine)
  done
end
end

lemma (in poly_set_iteratei) proper[proper_it]:
  "proper_it' iteratei iteratei"
  apply (rule proper_it'I)
  by (rule pi_iteratei)

lemma (in poly_set_iteratei) autoref_iteratei[autoref_ga_rules]: 
  "REL_IS_ID Rk  is_set_to_list Rk rel (it_to_list iteratei)"
  unfolding is_set_to_list_def is_set_to_sorted_list_def it_to_list_def 
    it_to_sorted_list_def
  apply (simp add: br_def, intro allI impI)
  apply (drule iteratei_correct)
  unfolding set_iterator_def set_iterator_genord_foldli_conv
  apply (elim exE)
  apply clarsimp
  apply (drule fun_cong[where x="λ_::'x list. True"])
  apply simp
  done

lemma (in poly_set_iterateoi) proper_o[proper_it]:
  "proper_it' iterateoi iterateoi"
  apply (rule proper_it'I)
  by (rule pi_iterateoi)

lemma (in poly_set_iterateoi) autoref_iterateoi[autoref_ga_rules]: 
  "REL_IS_ID Rk  
    is_set_to_sorted_list (≤) Rk rel (it_to_list iterateoi)"
  unfolding is_set_to_sorted_list_def it_to_list_def it_to_sorted_list_def
  apply (simp add: br_def, intro allI impI)
  apply (drule iterateoi_correct)
  unfolding set_iterator_linord_def set_iterator_genord_foldli_conv
  apply (elim exE)
  apply clarsimp
  apply (drule fun_cong[where x="λ_::'x list. True"])
  apply simp
  done

lemma (in poly_set_rev_iterateoi) autoref_rev_iterateoi[autoref_ga_rules]: 
  "REL_IS_ID Rk  
    is_set_to_sorted_list (≥) Rk rel (it_to_list rev_iterateoi)"
  unfolding is_set_to_sorted_list_def it_to_list_def it_to_sorted_list_def
  apply (simp add: br_def, intro allI impI)
  apply (drule rev_iterateoi_correct)
  unfolding set_iterator_rev_linord_def set_iterator_genord_foldli_conv
  apply (elim exE)
  apply clarsimp
  apply (drule fun_cong[where x="λ_::'x list. True"])
  apply simp
  done

lemma (in poly_set_rev_iterateoi) proper_ro[proper_it]:
  "proper_it' rev_iterateoi rev_iterateoi"
  apply (rule proper_it'I)
  by (rule pi_rev_iterateoi)

subsection "Map"

lemma (in map) rel_alt: "Id,Rvrel = 
  { (c,a). x. (α c x,a x)Rvoption_rel  invar c }"
  by (auto simp: rel_def br_def dest: fun_relD)

lemma (in map_empty) empty_autoref[autoref_rules]: 
  "PREFER_id Rk  (empty (),op_map_empty)Rk,Rvrel"
  by (auto simp: empty_correct rel_alt)
  
lemma (in map_lookup) lookup_autoref[autoref_rules]: 
  "PREFER_id Rk  (lookup,op_map_lookup)RkRk,RvrelRvoption_rel"
  apply (intro fun_relI option_relI)
  apply (auto simp: lookup_correct rel_alt
    dest: fun_relD2)
  done

lemma (in map_update) update_autoref[autoref_rules]: 
  "PREFER_id Rk  (update,op_map_update)RkRvRk,RvrelRk,Rvrel"
  apply (intro fun_relI)
  apply (simp add: update_correct rel_alt)
  done

context map_update_dj begin
context begin interpretation autoref_syn .

lemma update_dj_autoref[autoref_rules]: 
  assumes "SIDE_PRECOND_OPT (k'dom m')"
  assumes "PREFER_id Rk"
  assumes "(k,k')Rk"
  assumes "(v,v')Rv"
  assumes "(m,m')Rk,Rvrel"
  shows "(update_dj k v m,
    (OP op_map_update ::: Rk  Rv  Rk,Rvrel  Rk,Rvrel)$k'$v'$m'
  )Rk,Rvrel"
  using assms
  apply (subgoal_tac "kdom (α m)")
  apply (simp add: update_dj_correct rel_alt)
  apply (auto simp add: rel_alt option_rel_def)
  apply (metis option.simps(3))
  done
end
end

lemma (in map_delete) delete_autoref[autoref_rules]: 
  "PREFER_id Rk  (delete,op_map_delete)RkRk,RvrelRk,Rvrel"
  apply (intro fun_relI)
  apply (simp add: delete_correct restrict_map_def rel_alt)
  done

lemma (in map_restrict) restrict_autoref[autoref_rules]: 
  "PREFER_id Rk  
    (restrict,op_map_restrict) 
     (Rk,Rvprod_rel  Id)  Rk,Rvm1.rel  Rk,Rvm2.rel"
  apply (intro fun_relI)
  apply (simp add: restrict_correct br_comp_alt m1.rel_def m2.rel_def )
  apply (intro fun_relI)
  apply (auto simp: restrict_map_def split: if_split_asm)
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def) []
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def) []
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def prod_rel_def fun_rel_def) []
  apply (drule (1) fun_relD2)
  apply (auto simp: option_rel_def prod_rel_def fun_rel_def) []
  done

lemma (in map_add) add_autoref[autoref_rules]: 
  "PREFER_id Rk  (add,(++))Rk,RvrelRk,RvrelRk,Rvrel"
  apply (auto simp add: add_correct rel_alt Map.map_add_def
    split: option.split)
  apply (drule_tac x=x in spec)+
  apply simp
  apply (metis option.simps(3) option_rel_simp(2))
  by (metis (lifting) option_rel_simp(3))


context map_add_dj begin
context begin interpretation autoref_syn .

lemma add_dj_autoref[autoref_rules]: 
  assumes "PREFER_id Rk"
  assumes "SIDE_PRECOND_OPT (dom a'  dom b' = {})"
  assumes "(a,a')Rk,Rvrel"
  assumes "(b,b')Rk,Rvrel"
  shows "(add_dj a b, (OP (++) ::: Rk,Rvrel  Rk,Rvrel  Rk,Rvrel) $ a' $ b')Rk,Rvrel"
  using assms
  apply simp
  apply (subgoal_tac "dom (α a)  dom (α b) = {}")
  apply (clarsimp simp add: add_dj_correct rel_def br_comp_alt)
  apply (auto 
    simp add: rel_def br_comp_alt Map.map_add_def
    split: option.split
    elim: fun_relE1 dest: fun_relD1 intro: option_relI
  ) []

  apply (clarsimp simp add: rel_def br_comp_alt)

  apply (auto simp: dom_def)
  apply (drule (1) fun_relD1)
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def)
  done
end
end

lemma (in map_isEmpty) isEmpty_autoref[autoref_rules]: 
  "PREFER_id Rk  (isEmpty,op_map_isEmpty)Rk,RvrelId"
  by (auto simp: isEmpty_correct rel_alt
    intro!: ext)

lemma sngI: 
  assumes "m k = Some v"
  assumes "k'. k'k  m k' = None"
  shows "m = [kv]"
  using assms
  by (auto intro!: ext)

lemma (in map_isSng) isSng_autoref[autoref_rules]: 
  "PREFER_id Rk  (isSng,op_map_isSng)Rk,RvrelId"
  (* TODO: Clean up this mess *)
  apply (auto simp add: isSng_correct rel_alt)
  apply (rule_tac x=k in exI)
  apply (rule_tac x="the (a' k)" in exI)
  apply (rule sngI)
  apply (drule_tac x=k in spec)
  apply (auto elim: option_relE) []
  apply (force elim: option_relE) []

  apply (rule_tac x=k in exI)
  apply (rule_tac x="the (α a k)" in exI)
  apply (rule sngI)
  apply (drule_tac x=k in spec)
  apply (auto elim: option_relE) []
  apply (force elim: option_relE) []
  done

lemma (in map_ball) ball_autoref[autoref_rules]:
  "PREFER_id Rk  (ball,op_map_ball)Rk,Rvrel(Rk,Rvprod_relId)Id"
  apply (auto simp: ball_correct rel_alt map_to_set_def
    option_rel_def prod_rel_def fun_rel_def)
  apply (metis option.inject option.simps(3))+
  done

lemma (in map_bex) bex_autoref[autoref_rules]:
  "PREFER_id Rk  (bex,op_map_bex)Rk,Rvrel(Rk,Rvprod_relId)Id"
  apply (auto simp: bex_correct map_to_set_def rel_alt 
    option_rel_def prod_rel_def fun_rel_def)
  apply (metis option.inject option.simps(3))+
  done

lemma (in map_size) size_autoref[autoref_rules]:
  "PREFER_id Rk  (size,op_map_size)Rk,RvrelId"
  apply (auto simp: size_correct rel_alt option_rel_def dom_def 
    intro!: arg_cong[where f=card])
  apply (metis option.simps(3))+
  done

lemma (in map_size_abort) size_abort_autoref[autoref_rules]:
  "PREFER_id Rk  (size_abort,op_map_size_abort)IdRk,RvrelId"
  apply (auto simp: size_abort_correct  
    rel_alt option_rel_def
    dom_def intro!: arg_cong[where f=card] cong[OF arg_cong[where f=min]])
  apply (metis option.simps(3))+
  done

lemma (in list_to_map) to_map_autoref[autoref_rules]:
  "PREFER_id Rk  (to_map,map_of) Rk,Rvprod_rellist_rel  Rk,Rvrel"
proof (intro fun_relI)
  fix l :: "('u×'v) list" and l' :: "('u×'a) list"
  assume "PREFER_id Rk" hence [simp]: "Rk=Id" by simp
  assume "(l,l')Rk,Rvprod_rellist_rel"
  thus "(to_map l, map_of l')  Rk,Rvrel"
    apply (simp add: list_rel_def)
  proof (induct rule: list_all2_induct)
    case Nil thus ?case 
      by (auto simp add: to_map_correct rel_alt)
  next
    case (Cons x x' l l') thus ?case
      by (auto simp add: to_map_correct 
        rel_alt prod_rel_def)
  qed
qed

(* TODO: Move *)
lemma key_rel_true[simp]: "key_rel (λ_ _. True) = (λ_ _. True)"
  by (auto intro!: ext simp: key_rel_def)


lemma (in poly_map_iteratei) proper[proper_it]:
  "proper_it' iteratei iteratei"
  apply (rule proper_it'I)
  by (rule pi_iteratei)

lemma (in poly_map_iteratei) autoref_iteratei[autoref_ga_rules]: 
  assumes ID: "REL_IS_ID Rk"
    "REL_IS_ID Rv" (* TODO: Unnecessary*)
  shows "is_map_to_list Rk Rv rel (it_to_list iteratei)"
proof -
  from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all

  show ?thesis
    unfolding is_map_to_sorted_list_def is_map_to_list_def
      it_to_sorted_list_def
    apply simp
    apply (intro allI impI conjI)
  proof -
    fix m m'
    assume "(m, m')  br α invar"
    hence I: "invar m" and M': "m' = α m" by (simp_all add: br_def)

    have [simp]: "c. (λ(_,_). c) = (λ_. c)" by auto

    from map_it_to_list_genord_correct[where it = iteratei, 
      where R="λ_ _. True", simplified, OF 
      iteratei_correct[OF I, unfolded set_iterator_def]
    ] have 
        M: "Map.map_of (it_to_list iteratei m) = α m"
        and D: "distinct (List.map fst (it_to_list iteratei m))"
      by (simp_all)

    from D show "distinct (it_to_list iteratei m)"
      by (rule distinct_mapI)

    from M show "map_to_set m' = set (it_to_list iteratei m)"
      by (simp add: M' map_of_map_to_set[OF D])
  qed
qed

lemma (in poly_map_iterateoi) proper_o[proper_it]:
  "proper_it' iterateoi iterateoi"
  apply (rule proper_it'I)
  by (rule pi_iterateoi)

lemma (in poly_map_iterateoi) autoref_iterateoi[autoref_ga_rules]: 
  assumes ID: "REL_IS_ID Rk"
    "REL_IS_ID Rv" (* TODO: Unnecessary*)
  shows "is_map_to_sorted_list (≤) Rk Rv rel (it_to_list iterateoi)"
proof -
  from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all

  show ?thesis
    unfolding is_map_to_sorted_list_def
      it_to_sorted_list_def
    apply simp
    apply (intro allI impI conjI)
  proof -
    fix m m'
    assume "(m, m')  br α invar"
    hence I: "invar m" and M': "m' = α m" by (simp_all add: br_def)

    have [simp]: "c. (λ(_,_). c) = (λ_. c)" by auto

    from map_it_to_list_linord_correct[where it = iterateoi, 
      OF iterateoi_correct[OF I]
    ] have 
        M: "map_of (it_to_list iterateoi m) = α m"
        and D: "distinct (map fst (it_to_list iterateoi m))"
        and S: "sorted (map fst (it_to_list iterateoi m))"
      by (simp_all)

    from D show "distinct (it_to_list iterateoi m)"
      by (rule distinct_mapI)

    from M show "map_to_set m' = set (it_to_list iterateoi m)"
      by (simp add: M' map_of_map_to_set[OF D])

    from S show "sorted_wrt (key_rel (≤)) (it_to_list iterateoi m)"
      by (simp add: key_rel_def[abs_def])

  qed
qed

lemma (in poly_map_rev_iterateoi) proper_ro[proper_it]:
  "proper_it' rev_iterateoi rev_iterateoi"
  apply (rule proper_it'I)
  by (rule pi_rev_iterateoi)

lemma (in poly_map_rev_iterateoi) autoref_rev_iterateoi[autoref_ga_rules]: 
  assumes ID: "REL_IS_ID Rk"
    "REL_IS_ID Rv" (* TODO: Unnecessary*)
  shows "is_map_to_sorted_list (≥) Rk Rv rel (it_to_list rev_iterateoi)"
proof -
  from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all

  show ?thesis
    unfolding is_map_to_sorted_list_def
      it_to_sorted_list_def
    apply simp
    apply (intro allI impI conjI)
  proof -
    fix m m'
    assume "(m, m')  br α invar"
    hence I: "invar m" and M': "m' = α m" by (simp_all add: br_def)

    have [simp]: "c. (λ(_,_). c) = (λ_. c)" by auto

    from map_it_to_list_rev_linord_correct[where it = rev_iterateoi, 
      OF rev_iterateoi_correct[OF I]
    ] have 
        M: "map_of (it_to_list rev_iterateoi m) = α m"
        and D: "distinct (map fst (it_to_list rev_iterateoi m))"
        and S: "sorted (rev (map fst (it_to_list rev_iterateoi m)))"
      by (simp_all)

    from D show "distinct (it_to_list rev_iterateoi m)"
      by (rule distinct_mapI)

    from M show "map_to_set m' = set (it_to_list rev_iterateoi m)"
      by (simp add: M' map_of_map_to_set[OF D])

    from S show "sorted_wrt (key_rel (≥)) (it_to_list rev_iterateoi m)"
      by (simp add: key_rel_def[abs_def])

  qed
qed

end

Theory ICF_Entrypoints_Chapter

(*<*)
theory ICF_Entrypoints_Chapter imports Main begin 
(*>*)
text_raw ‹\isasection{Entry Points}›
(*<*)
end
(*>*)

Theory Collections

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section ‹\isaheader{Standard Collections}›
theory Collections
imports
  ICF_Impl
  ICF_Refine_Monadic
  ICF_Autoref
(* Miscellanneous*)
  DatRef

begin
  text ‹
    This theory summarizes the components of the Isabelle Collection Framework.
›
end

Theory CollectionsV1

section ‹Backwards Compatibility for Version 1›
theory CollectionsV1
imports Collections
begin
  text ‹
    This theory defines some stuff to establish (partial) backwards
    compatibility with ICF Version 1.
›

  (*
    TODO: Dirty hack to workaround a problem that occurs with sublocale here:
      When declaring
        
  sublocale poly_map_iteratei < v1_iteratei: map_iteratei α invar iteratei
    by (rule v1_iteratei_impl)

      Any further 

  interpretation StdMap hm_ops

    will fail with
*** exception TYPE raised (line 414 of "type.ML"):
*** Type variable "?'a" has two distinct sorts
*** ?'a::type
*** ?'a::hashable

  The problem seems difficult to track down, as it, e.g., does not iccur for 
  sets.
*)

  attribute_setup locale_witness_add = ‹
    Scan.succeed (Locale.witness_add) "Add witness for locale instantiation. HACK, use 
      sublocale or interpretation whereever possible!"


  subsection ‹Iterators›
  text ‹We define all the monomorphic iterator locales›
  subsubsection "Set"
locale set_iteratei = finite_set α invar for α :: "'s  'x set" and invar +
  fixes iteratei :: "'s  ('x, ) set_iterator"

  assumes iteratei_rule: "invar S  set_iterator (iteratei S) (α S)"
begin
  lemma iteratei_rule_P:
    "
      invar S;
      I (α S) σ0;
      !!x it σ.  c σ; x  it; it  α S; I it σ   I (it - {x}) (f x σ);
      !!σ. I {} σ  P σ;
      !!σ it.  it  α S; it  {}; ¬ c σ; I it σ   P σ
      P (iteratei S c f σ0)"
   apply (rule set_iterator_rule_P [OF iteratei_rule, of S I σ0 c f P])
   apply simp_all
  done

  lemma iteratei_rule_insert_P:
    "
      invar S;
      I {} σ0;
      !!x it σ.  c σ; x  α S - it; it  α S; I it σ   I (insert x it) (f x σ);
      !!σ. I (α S) σ  P σ;
      !!σ it.  it  α S; it  α S; ¬ c σ; I it σ   P σ
      P (iteratei S c f σ0)"
    apply (rule set_iterator_rule_insert_P [OF iteratei_rule, of S I σ0 c f P])
    apply simp_all
  done

  text ‹Versions without break condition.›
  lemma iterate_rule_P:
    "
      invar S;
      I (α S) σ0;
      !!x it σ.  x  it; it  α S; I it σ   I (it - {x}) (f x σ);
      !!σ. I {} σ  P σ
      P (iteratei S (λ_. True) f σ0)"
   apply (rule set_iterator_no_cond_rule_P [OF iteratei_rule, of S I σ0 f P])
   apply simp_all
  done

  lemma iterate_rule_insert_P:
    "
      invar S;
      I {} σ0;
      !!x it σ.  x  α S - it; it  α S; I it σ   I (insert x it) (f x σ);
      !!σ. I (α S) σ  P σ
      P (iteratei S (λ_. True) f σ0)"
    apply (rule set_iterator_no_cond_rule_insert_P [OF iteratei_rule, of S I σ0 f P])
    apply simp_all
  done
end

lemma set_iteratei_I :
assumes "s. invar s  set_iterator (iti s) (α s)"
shows "set_iteratei α invar iti"
proof
  fix s 
  assume invar_s: "invar s"
  from assms(1)[OF invar_s] show it_OK: "set_iterator (iti s) (α s)" .
  
  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (α s)" .
qed

  locale set_iterateoi = ordered_finite_set α invar
    for α :: "'s  ('u::linorder) set" and invar
    +
    fixes iterateoi :: "'s  ('u,) set_iterator"
    assumes iterateoi_rule: 
      "invar s  set_iterator_linord (iterateoi s) (α s)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (α m) σ0"
      assumes IP: "!!k it σ.  
        c σ; 
        k  it; 
        jit. kj; 
        jα m - it. jk; 
        it  α m; 
        I it σ 
        I (it - {k}) (f k σ)"
      assumes IF: "!!σ. I {} σ  P σ"
      assumes II: "!!σ it.  
        it  α m; 
        it  {}; 
        ¬ c σ; 
        I it σ; 
        kit. jα m - it. jk 
        P σ"
      shows "P (iterateoi m c f σ0)"  
    using set_iterator_linord_rule_P [OF iterateoi_rule, OF MINV, of I σ0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]: 
      assumes MINV: "invar m"
      assumes I0: "I ((α m)) σ0"
      assumes IP: "!!k it σ.  k  it; jit. kj; j(α m) - it. jk; it  (α m); I it σ  
                   I (it - {k}) (f k σ)"
      assumes IF: "!!σ. I {} σ  P σ"
    shows "P (iterateoi m (λ_. True) f σ0)"
      apply (rule iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_iterateoi_I :
  assumes "s. invar s  set_iterator_linord (itoi s) (α s)"
  shows "set_iterateoi α invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_linord (itoi s) (α s)" .
  
    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_linord_def]]
    show "finite (α s)" by simp 
  qed

  (* Deprecated *)
  locale set_reverse_iterateoi = ordered_finite_set α invar 
    for α :: "'s  ('u::linorder) set" and invar
    +
    fixes reverse_iterateoi :: "'s  ('u,) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m  set_iterator_rev_linord (reverse_iterateoi m) (α m)" 
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I ((α m)) σ0"
      assumes IP: "!!k it σ.  
        c σ; 
        k  it; 
        jit. kj; 
        j(α m) - it. jk; 
        it  (α m); 
        I it σ 
        I (it - {k}) (f k σ)"
      assumes IF: "!!σ. I {} σ  P σ"
      assumes II: "!!σ it.  
        it  (α m); 
        it  {}; 
        ¬ c σ; 
        I it σ; 
        kit. j(α m) - it. jk 
        P σ"
    shows "P (reverse_iterateoi m c f σ0)"
    using set_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, OF MINV, of I σ0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I ((α m)) σ0"
      assumes IP: "!!k it σ.  
        k  it; 
        jit. kj; 
        j (α m) - it. jk; 
        it  (α m); 
        I it σ 
        I (it - {k}) (f k σ)"
      assumes IF: "!!σ. I {} σ  P σ"
    shows "P (reverse_iterateoi m (λ_. True) f σ0)"
      apply (rule reverse_iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_reverse_iterateoi_I :
  assumes "s. invar s  set_iterator_rev_linord (itoi s) (α s)"
  shows "set_reverse_iterateoi α invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_rev_linord (itoi s) (α s)" .
  
    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_rev_linord_def]]
    show "finite (α s)" by simp 
  qed


  lemma (in poly_set_iteratei) v1_iteratei_impl: 
    "set_iteratei α invar iteratei"
    by unfold_locales (rule iteratei_correct)
  lemma (in poly_set_iterateoi) v1_iterateoi_impl: 
    "set_iterateoi α invar iterateoi"
    by unfold_locales (rule iterateoi_correct)
  lemma (in poly_set_rev_iterateoi) v1_reverse_iterateoi_impl: 
    "set_reverse_iterateoi α invar rev_iterateoi"
    by unfold_locales (rule rev_iterateoi_correct)

  declare (in poly_set_iteratei) v1_iteratei_impl[locale_witness_add]
  declare (in poly_set_iterateoi) v1_iterateoi_impl[locale_witness_add]
  declare (in poly_set_rev_iterateoi) 
    v1_reverse_iterateoi_impl[locale_witness_add]

  (* Commented out, as it causes strange errors of the kind:
    Type variable "?'a" has two distinct sorts

  sublocale poly_set_iteratei < v1_iteratei: set_iteratei α invar iteratei
    by (rule v1_iteratei_impl)
  sublocale poly_set_iterateoi < v1_iteratei: set_iterateoi α invar iterateoi
    by (rule v1_iterateoi_impl)
  sublocale poly_set_rev_iterateoi 
    < v1_iteratei!: set_reverse_iterateoi α invar rev_iterateoi
    by (rule v1_reverse_iterateoi_impl)
    *)

subsubsection "Map"
locale map_iteratei = finite_map α invar for α :: "'s  'u  'v" and invar +
  fixes iteratei :: "'s  ('u × 'v,) set_iterator"

  assumes iteratei_rule: "invar m  map_iterator (iteratei m) (α m)"
begin

  lemma iteratei_rule_P:
    assumes "invar m"
        and I0: "I (dom (α m)) σ0"
        and IP: "!!k v it σ.  c σ; k  it; α m k = Some v; it  dom (α m); I it σ  
                     I (it - {k}) (f (k, v) σ)"
        and IF: "!!σ. I {} σ  P σ"
        and II: "!!σ it.  it  dom (α m); it  {}; ¬ c σ; I it σ   P σ"
    shows "P (iteratei m c f σ0)"
    using map_iterator_rule_P [OF iteratei_rule, of m I σ0 c f P]
    by (simp_all add: assms)

  lemma iteratei_rule_insert_P:
    assumes  
      "invar m" 
      "I {} σ0"
      "!!k v it σ.  c σ; k  (dom (α m) - it); α m k = Some v; it  dom (α m); I it σ  
           I (insert k it) (f (k, v) σ)"
      "!!σ. I (dom (α m)) σ  P σ"
      "!!σ it.  it  dom (α m); it  dom (α m); 
               ¬ (c σ); 
               I it σ   P σ"
    shows "P (iteratei m c f σ0)"
    using map_iterator_rule_insert_P [OF iteratei_rule, of m I σ0 c f P]
    by (simp_all add: assms)

  lemma iterate_rule_P:
    "
      invar m;
      I (dom (α m)) σ0;
      !!k v it σ.  k  it; α m k = Some v; it  dom (α m); I it σ  
                   I (it - {k}) (f (k, v) σ);
      !!σ. I {} σ  P σ
      P (iteratei m (λ_. True) f σ0)"
    using iteratei_rule_P [of m I σ0 "λ_. True" f P]
    by fast

  lemma iterate_rule_insert_P:
    "
      invar m;
      I {} σ0;
      !!k v it σ.  k  (dom (α m) - it); α m k = Some v; it  dom (α m); I it σ  
                   I (insert k it) (f (k, v) σ);
      !!σ. I (dom (α m)) σ  P σ
      P (iteratei m (λ_. True) f σ0)"
    using iteratei_rule_insert_P [of m I σ0 "λ_. True" f P]
    by fast
end

lemma map_iteratei_I :
  assumes "m. invar m  map_iterator (iti m) (α m)"
  shows "map_iteratei α invar iti"
proof
  fix m 
  assume invar_m: "invar m"
  from assms(1)[OF invar_m] show it_OK: "map_iterator (iti m) (α m)" .
  
  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (dom (α m))" by (simp add: finite_map_to_set) 
qed


  locale map_iterateoi = ordered_finite_map α invar
    for α :: "'s  ('u::linorder)  'v" and invar
    +
    fixes iterateoi :: "'s  ('u × 'v,) set_iterator"
    assumes iterateoi_rule: "
      invar m  map_iterator_linord (iterateoi m) (α m)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (α m)) σ0"
      assumes IP: "!!k v it σ.  
        c σ; 
        k  it; 
        jit. kj; 
        jdom (α m) - it. jk; 
        α m k = Some v; 
        it  dom (α m); 
        I it σ 
        I (it - {k}) (f (k, v) σ)"
      assumes IF: "!!σ. I {} σ  P σ"
      assumes II: "!!σ it.  
        it  dom (α m); 
        it  {}; 
        ¬ c σ; 
        I it σ; 
        kit. jdom (α m) - it. jk 
        P σ"
      shows "P (iterateoi m c f σ0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I σ0 c f P] assms
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]: 
      assumes MINV: "invar m"
      assumes I0: "I (dom (α m)) σ0"
      assumes IP: "!!k v it σ.  k  it; jit. kj; jdom (α m) - it. jk; α m k = Some v; it  dom (α m); I it σ  
                   I (it - {k}) (f (k, v) σ)"
      assumes IF: "!!σ. I {} σ  P σ"
      shows "P (iterateoi m (λ_. True) f σ0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I σ0 "λ_. True" f P] assms
    by simp
  end

  lemma map_iterateoi_I :
  assumes "m. invar m  map_iterator_linord (itoi m) (α m)"
  shows "map_iterateoi α invar itoi"
  proof
    fix m 
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_linord (itoi m) (α m)" .
  
    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_linord_def]]
    show "finite (dom (α m))" by (simp add: finite_map_to_set) 
  qed

  locale map_reverse_iterateoi = ordered_finite_map α invar 
    for α :: "'s  ('u::linorder)  'v" and invar
    +
    fixes reverse_iterateoi :: "'s  ('u × 'v,) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m  map_iterator_rev_linord (reverse_iterateoi m) (α m)"
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (α m)) σ0"
      assumes IP: "!!k v it σ.  
        c σ; 
        k  it; 
        jit. kj; 
        jdom (α m) - it. jk; 
        α m k = Some v; 
        it  dom (α m); 
        I it σ 
        I (it - {k}) (f (k, v) σ)"
      assumes IF: "!!σ. I {} σ  P σ"
      assumes II: "!!σ it.  
        it  dom (α m); 
        it  {}; 
        ¬ c σ; 
        I it σ; 
        kit. jdom (α m) - it. jk 
        P σ"
      shows "P (reverse_iterateoi m c f σ0)"
    using map_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, of m I σ0 c f P] assms
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (α m)) σ0"
      assumes IP: "!!k v it σ.  
        k  it; 
        jit. kj; 
        jdom (α m) - it. jk; 
        α m k = Some v; 
        it  dom (α m); 
        I it σ 
        I (it - {k}) (f (k, v) σ)"
      assumes IF: "!!σ. I {} σ  P σ"
      shows "P (reverse_iterateoi m (λ_. True) f σ0)"
    using map_iterator_rev_linord_rule_P[OF reverse_iterateoi_rule, of m I σ0 "λ_. True" f P] assms
    by simp
  end

  lemma map_reverse_iterateoi_I :
  assumes "m. invar m  map_iterator_rev_linord (ritoi m) (α m)"
  shows "map_reverse_iterateoi α invar ritoi"
  proof
    fix m 
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_rev_linord (ritoi m) (α m)" .
  
    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_rev_linord_def]]
    show "finite (dom (α m))" by (simp add: finite_map_to_set) 
  qed


  lemma (in poly_map_iteratei) v1_iteratei_impl: 
    "map_iteratei α invar iteratei"
    by unfold_locales (rule iteratei_correct)
  lemma (in poly_map_iterateoi) v1_iterateoi_impl: 
    "map_iterateoi α invar iterateoi"
    by unfold_locales (rule iterateoi_correct)
  lemma (in poly_map_rev_iterateoi) v1_reverse_iterateoi_impl: 
    "map_reverse_iterateoi α invar rev_iterateoi"
    by unfold_locales (rule rev_iterateoi_correct)


  declare (in poly_map_iteratei) v1_iteratei_impl[locale_witness_add]
  declare (in poly_map_iterateoi) v1_iterateoi_impl[locale_witness_add]
  declare (in poly_map_rev_iterateoi) 
    v1_reverse_iterateoi_impl[locale_witness_add]

  (*
  sublocale poly_map_iteratei < v1_iteratei: map_iteratei α invar iteratei
    by (rule v1_iteratei_impl)
  sublocale poly_map_iterateoi < v1_iteratei: map_iterateoi α invar iterateoi
    by (rule v1_iterateoi_impl)
  sublocale poly_map_rev_iterateoi 
    < v1_iteratei!: map_reverse_iterateoi α invar rev_iterateoi
    by (rule v1_reverse_iterateoi_impl)
    *)

  subsection ‹Concrete Operation Names›
  text ‹We define abbreviations to recover the xx_op›-names›

  (* TODO: This may take long, as Local_Theory.abbrev seems to be really slow *)
  local_setup let
    val thy = @{theory}
    val ctxt = Proof_Context.init_global thy;
    val pats = [
    "hs","hm",
    "rs","rm",
    "ls","lm","lsi","lmi","lsnd","lss",
    "ts","tm",
    "ias","iam",
    "ahs","ahm",
    "bino",
    "fifo",
    "ft",
    "alprioi",
    "aluprioi",
    "skew"
    ];

    val {const_space, constants, ...} = Sign.consts_of thy |> Consts.dest
    val clist = Name_Space.extern_entries true ctxt const_space constants |> map (apfst #1)

    fun abbrevs_for pat = clist
    |> map_filter (fn (n,_) => case Long_Name.explode n of
        [_,prefix,opname] =>
          if prefix = pat then let 
              val aname = prefix ^ "_" ^ opname
              val rhs = Proof_Context.read_term_abbrev ctxt n
            in SOME (aname,rhs) end
          else NONE
      | _ => NONE);

    fun do_abbrevs pat lthy = let
      val abbrevs = abbrevs_for pat;
    in 
      case abbrevs of [] => (warning ("No stuff found for "^pat); lthy)
      | _ => let 
        (*val _ = tracing ("Defining " ^ pat ^ "_xxx ...");*)
        val lthy = fold (fn (name,rhs) =>
          Local_Theory.abbrev 
            Syntax.mode_input 
            ((Binding.name name,NoSyn),rhs) #> #2
        ) abbrevs lthy
        (*val _ = tracing "Done";*)
      in lthy end
    end
  in
    fold do_abbrevs pats
  end


lemmas hs_correct = hs.correct
lemmas hm_correct = hm.correct
lemmas rs_correct = rs.correct
lemmas rm_correct = rm.correct
lemmas ls_correct = ls.correct
lemmas lm_correct = lm.correct
lemmas lsi_correct = lsi.correct
lemmas lmi_correct = lmi.correct
lemmas lsnd_correct = lsnd.correct
lemmas lss_correct = lss.correct
lemmas ts_correct = ts.correct
lemmas tm_correct = tm.correct
lemmas ias_correct = ias.correct
lemmas iam_correct = iam.correct
lemmas ahs_correct = ahs.correct
lemmas ahm_correct = ahm.correct
lemmas bino_correct = bino.correct
lemmas fifo_correct = fifo.correct
lemmas ft_correct = ft.correct
lemmas alprioi_correct = alprioi.correct
lemmas aluprioi_correct = aluprioi.correct
lemmas skew_correct = skew.correct


locale list_enqueue = list_appendr
locale list_dequeue = list_removel

locale list_push = list_appendl
locale list_pop = list_remover
locale list_top = list_leftmost
locale list_bot = list_rightmost

instantiation rbt :: ("{equal,linorder}",equal) equal 
begin
  (*definition equal_rbt :: "('a,'b) RBT.rbt ⇒ _" where "equal_rbt ≡ (=)"*)

  definition "equal_class.equal (r :: ('a, 'b) rbt) r' 
    == RBT.impl_of r = RBT.impl_of r'"


  instance
    apply intro_classes
    apply (simp add: equal_rbt_def RBT.impl_of_inject)
    done
end

end

Theory Collections_Entrypoints_Chapter

(*<*)
theory Collections_Entrypoints_Chapter imports Main begin 
(*>*)
text_raw ‹\isachapter{Entry Points}›
text_raw ‹\isasection{Entry Points}›
text ‹
  This chapter describes the overall entrypoints to the combination of
  Automatic Refinement Framework, Monadic Refinement Framework, and 
  Collection Framework. These are the theories a typical algorithm development
  should be based on.
›

(*<*)
end
(*>*)

Theory Refine_Dflt

section ‹\isaheader{Default Setup}›
theory Refine_Dflt
imports 
  Refine_Monadic.Refine_Monadic
  "GenCF/GenCF"
  "Lib/Code_Target_ICF"
begin

text ‹Configurations›

lemmas tyrel_dflt_nat_set = 
  ty_REL[where 'a="nat set" and R="Iddflt_rs_rel"]

lemmas tyrel_dflt_bool_set = 
  ty_REL[where 'a="bool set" and R="Idlist_set_rel"]

lemmas tyrel_dflt_nat_map = 
  ty_REL[where R="nat_rel,Rvdflt_rm_rel"] for Rv

lemmas tyrel_dflt_old = tyrel_dflt_nat_set tyrel_dflt_bool_set tyrel_dflt_nat_map

lemmas tyrel_dflt_linorder_set = 
  ty_REL[where R="Id::('a::linorder×'a) setdflt_rs_rel"]
  
lemmas tyrel_dflt_linorder_map = 
  ty_REL[where R="Id::('a::linorder×'a) set,Rdflt_rm_rel"] for R
  
lemmas tyrel_dflt_bool_map = 
  ty_REL[where R="Id::(bool×bool) set,Rlist_map_rel"] for R

lemmas tyrel_dflt = tyrel_dflt_linorder_set tyrel_dflt_bool_set tyrel_dflt_linorder_map tyrel_dflt_bool_map

declare tyrel_dflt[autoref_tyrel]



local_setup let open Autoref_Fix_Rel in
    declare_prio "Gen-AHM-map-hashable" 
      @{term "Rk::(_×_::hashable) set,Rvahm_rel bhc"} PR_LAST #>
    declare_prio "Gen-RBT-map-linorder" 
      @{term "Rk::(_×_::linorder) set,Rvrbt_map_rel lt"} PR_LAST #>
    declare_prio "Gen-AHM-map" @{term "Rk,Rvahm_rel bhc"} PR_LAST #>
    declare_prio "Gen-RBT-map" @{term "Rk,Rvrbt_map_rel lt"} PR_LAST
  end


text "Fallbacks"
local_setup let open Autoref_Fix_Rel in
    declare_prio "Gen-List-Set" @{term "Rlist_set_rel"} PR_LAST #>
    declare_prio "Gen-List-Map" @{term "Rlist_map_rel"} PR_LAST
  end

text ‹Quick test of setup:›
context begin
private schematic_goal test_dflt_tyrel1: "(?c::?'c,{1,2,3::int})?R" (*RBT*)
  by autoref
private lemmas asm_rl[of "_int_reldflt_rs_rel", OF test_dflt_tyrel1]

private schematic_goal test_dflt_tyrel2: "(?c::?'c,{True, False})?R" (*List*)
  by autoref
private lemmas asm_rl[of "_bool_rellist_set_rel", OF test_dflt_tyrel2]

private schematic_goal test_dflt_tyrel3: "(?c::?'c,[1::int0::nat])?R" (*RBT*)
  by autoref
private lemmas asm_rl[of "_int_rel,nat_reldflt_rm_rel", OF test_dflt_tyrel3]

private schematic_goal test_dflt_tyrel4: "(?c::?'c,[False0::nat])?R" (*List*)
  by autoref
private lemmas asm_rl[of "_bool_rel,nat_rellist_map_rel", OF test_dflt_tyrel4]

end





end

Theory Refine_Dflt_ICF

section ‹\isaheader{Entry Point with genCF and original ICF}›
theory Refine_Dflt_ICF
imports 
  Refine_Monadic.Refine_Monadic
  "GenCF/GenCF"
  "ICF/Collections"
  "Lib/Code_Target_ICF"
begin


text ‹Contains the Monadic Refinement Framework, the generic collection 
  framework and the original Isabelle Collection Framework›

local_setup let open Autoref_Fix_Rel in
    declare_prio "Gen-RBT-set" @{term "Rdflt_rs_rel"} PR_LAST #>
    declare_prio "RBT-set" @{term "Rrs.rel"} PR_LAST #>
    declare_prio "Hash-set" @{term "Rhs.rel"} PR_LAST #>
    declare_prio "List-set" @{term "Rlsi.rel"} PR_LAST
  end

local_setup let open Autoref_Fix_Rel in
    declare_prio "RBT-map" @{term "Rk,Rvrm.rel"} PR_LAST #>
    declare_prio "Hash-map" @{term "Rk,Rvhm.rel"} PR_LAST #>
    (* declare_prio "Gen-RBT-map" @{term "⟨Rk,Rv⟩rbt_map_rel ?cmp"} PR_LAST #>*)
    declare_prio "List-map" @{term "Rk,Rvlmi.rel"} PR_LAST
  end

text "Fallbacks"
local_setup let open Autoref_Fix_Rel in
    declare_prio "Gen-List-Set" @{term "Rlist_set_rel"} PR_LAST #>
    declare_prio "Gen-List-Map" @{term "Rk,Rvlist_map_rel"} PR_LAST
  end

class id_refine

instance nat :: id_refine ..
instance bool :: id_refine ..
instance int :: id_refine ..

lemmas [autoref_tyrel] = 
  ty_REL[where 'a="nat" and R="nat_rel"]
  ty_REL[where 'a="int" and R="int_rel"]
  ty_REL[where 'a="bool" and R="bool_rel"]
lemmas [autoref_tyrel] = 
  ty_REL[where 'a="nat set" and R="Idrs.rel"]
  ty_REL[where 'a="int set" and R="Idrs.rel"]
  ty_REL[where 'a="bool set" and R="Idlsi.rel"]
lemmas [autoref_tyrel] = 
  ty_REL[where 'a="(nat  'b)", where R="nat_rel,Rvdflt_rm_rel"]
  ty_REL[where 'a="(int  'b)", where R="int_rel,Rvdflt_rm_rel"]
  ty_REL[where 'a="(bool  'b)", where R="bool_rel,Rvdflt_rm_rel"]
  for Rv

lemmas [autoref_tyrel] = 
  ty_REL[where 'a="(nat  'b::id_refine)", where R="nat_rel,Idrm.rel"]
  ty_REL[where 'a="(int  'b::id_refine)", where R="int_rel,Idrm.rel"]
  ty_REL[where 'a="(bool  'b::id_refine)", where R="bool_rel,Idrm.rel"]

end

Theory Refine_Dflt_Only_ICF

section ‹\isaheader{Entry Point with only the ICF}›
theory Refine_Dflt_Only_ICF
imports
  Refine_Monadic.Refine_Monadic
  "ICF/Collections"
  "Lib/Code_Target_ICF"
begin

text ‹Contains the Monadic Refinement Framework and the original
  Isabelle Collection Framework. The generic collection framework is
  not included›

local_setup let open Autoref_Fix_Rel in
    declare_prio "RBT-set" @{term "Rrs.rel"} PR_LAST #>
    declare_prio "Hash-set" @{term "Rhs.rel"} PR_LAST #>
    declare_prio "List-set" @{term "Rlsi.rel"} PR_LAST
  end

local_setup let open Autoref_Fix_Rel in
    declare_prio "RBT-map" @{term "Rk,Rvrm.rel"} PR_LAST #>
    declare_prio "Hash-map" @{term "Rk,Rvhm.rel"} PR_LAST #>
    declare_prio "List-map" @{term "Rk,Rvlmi.rel"} PR_LAST
  end

end

Theory Userguides_Chapter

(*<*)
theory Userguides_Chapter imports Main begin 
(*>*)
text_raw ‹\isachapter{Userguides}›
text ‹
  This chapter contains various userguides.
›
(*<*)
end
(*>*)

Theory Refine_Monadic_Userguide

(*<*)
theory Refine_Monadic_Userguide
imports "../Refine_Dflt_Only_ICF"
begin
(*>*)

text_raw ‹\isasection{Old Monadic Refinement Framework Userguide}›

section ‹Introduction›
text ‹
  This is the old userguide from Refine-Monadic. It contains the
  manual approach of using the mondaic refinement framework with the
  Isabelle Collection Framework. An alternative, more simple approach is
  provided by the Automatic Refinement Framework and the 
  Generic Collection Framework.

  The Isabelle/HOL refinement framework is a library that supports
  program and data refinement.

  Programs are specified using a nondeterminism monad: 
  An element of the monad type is either a set of results, or
  the special element @{term "FAIL"}, that indicates a failed assertion.

  The bind-operation of the monad applies a function to all elements of the
  result-set, and joins all possible results.

  On the monad type, an ordering ≤› is defined, that is lifted subset
  ordering, where @{term "FAIL"} is the greatest element. Intuitively,
  @{term "SS'"} means that program S› refines program S'›, 
  i.e., all results of S› are also results of S'›, and 
  S› may only fail if S'› also fails.
›

section ‹Guided Tour›
text ‹
  In this section, we provide a small example program development in our 
  framework. All steps of the development are heavily commented.
›

subsection ‹Defining Programs›
text ‹
  A program is defined using the Haskell-like do-notation, that is provided by
  the Isabelle/HOL library. We start with a simple example, that iterates
  over a set of numbers, and computes the maximum value and the sum of
  all elements.
›

definition sum_max :: "nat set  (nat×nat) nres" where
  "sum_max V  do {
    (_,s,m)  WHILE (λ(V,s,m). V{}) (λ(V,s,m). do {
      xSPEC (λx. xV); 
      let V=V-{x};
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

text ‹
  The type of the nondeterminism monad is @{typ "'a nres"}, where @{typ "'a"}
  is the type of the results. Note that this program has only one possible
  result, however, the order in which we iterate over the elements of the set
  is unspecified.

  This program uses the following statements provided by our framework:
  While-loops, bindings, return, and specification. We briefly explain the
  statements here. A complete reference can be found in 
  Section~\ref{sec:stmt_ref}.

  A while-loop has the form @{term "WHILE b f σ0"}, where @{term "b"} is the
  continuation condition, @{term "f"} is the loop body, and @{term "σ0"} is
  the initial state. In our case, the state used for the loop is a triple
  @{term "(V,s,m)"}, where @{term "V"} is the set of remaining elements,
  @{term "s"} is the sum of the elements seen so far, and @{term "m"} is 
  the maximum of the elements seen so far.
  The @{term "WHILE b f σ0"} construct describes a partially correct loop,
  i.e., it describes only those results that can be reached by finitely many
  iterations, and ignores infinite paths of the loop. In order to 
  prove total correctness, the construct @{term "WHILET b f σ0"} is used. It
  fails if there exists an infinite execution of the loop.

  A binding @{term [source] "do {x(S1::'a nres); S2}"} nondeterministically 
  chooses a result of 
  @{term "S1"}, binds it to variable @{term "x"}, and then continues with 
  @{term "S2"}. If @{term "S1"} is @{const "FAIL"}, the 
  bind statement also fails. 

  The syntactic form @{term [source] "do { let x=V; (S::'a  'b nres)}"} 
  assigns the value V› to variable x›, and continues with 
  S›. 

  The return statement @{term "RETURN x"} specifies precisely the result 
  x›. 

  The specification statement @{term "SPEC Φ"} describes all results that 
  satisfy the predicate Φ›. This is the source of nondeterminism in
  programs, as there may be more than one such result. In our case, we describe
  any element of set V›.

  Note that these statement are shallowly embedded into Isabelle/HOL, i.e.,
  they are ordinary Isabelle/HOL constants. The main advantage is, that any 
  other construct and datatype from Isabelle/HOL may be used inside programs.
  In our case, we use Isabelle/HOL's predefined operations on sets and natural
  numbers. Another advantage is that extending the framework with new commands
  becomes fairly easy.
›

subsection ‹Proving Programs Correct›
text ‹
  The next step in the program development is to prove the program correct
  w.r.t.\ a specification. In refinement notion, we have to prove that the
  program S› refines a specification Φ› if the precondition
  Ψ› holds, i.e., @{term "Ψ  S  SPEC Φ"}.

  For our purposes, we prove that @{const "sum_max"} really computes the sum 
  and the maximum.
›

text ‹
  As usual, we have to think of a loop invariant first. In our case, this
  is rather straightforward. The main complication is introduced by the
  partially defined Max›-operator of the Isabelle/HOL standard library.
›
definition "sum_max_invar V0  λ(V,s::nat,m).
             VV0
            s=(V0-V) 
            m=(if (V0-V)={} then 0 else Max (V0-V)) 
            finite (V0-V)"


text ‹
  We have extracted the most complex verification condition 
  --- that the invariant is preserved by the loop body --- to
  an own lemma. For complex proofs, it is always a good idea to do that,
  as it makes the proof more readable.
›
lemma sum_max_invar_step:
  assumes "xV" "sum_max_invar V0 (V,s,m)"
  shows "sum_max_invar V0 (V-{x},s+x,max m x)"
  txt ‹In our case the proof is rather straightforward, it only
    requires the lemma @{thm [source] it_step_insert_iff}, that handles
    the @{term "(V0-(V-{x}))"} terms that occur in the invariant.›
  using assms unfolding sum_max_invar_def by (auto simp: it_step_insert_iff)

text ‹
  The correctness is now proved by first invoking the verification condition
  generator, and then discharging the verification conditions by 
  auto›. Note that we have to apply the 
  @{thm [source] sum_max_invar_step} lemma, {\em before} we unfold the 
  definition of the invariant to discharge the remaining verification 
  conditions.
›
theorem sum_max_correct:
  assumes PRE: "V{}" 
  shows "sum_max V  SPEC (λ(s,m). s=V  m=Max V)"
  txt ‹
    The precondition V≠{}› is necessary, as the
    Max›-operator from Isabelle/HOL's standard library is not defined
    for empty sets.
›
  using PRE unfolding sum_max_def
  apply (intro WHILE_rule[where I="sum_max_invar V"] refine_vcg) ― ‹Invoke vcg›
  txt ‹Note that we have explicitely instantiated 
    the rule for the while-loop with the invariant. If this is not done,
    the verification condition generator will stop at the WHILE-loop.
›
  apply (auto intro: sum_max_invar_step) ― ‹Discharge step›
  unfolding sum_max_invar_def ― ‹Unfold invariant definition›
  apply (auto) ― ‹Discharge remaining goals›
  done

text ‹
  In this proof, we specified the invariant explicitely.
  Alternatively, we may annotate the invariant at the while loop,
  using the syntax @{term "WHILEI b f σ0"}. Then, the verification condition
  generator will use the annotated invariant automatically.
›

text_raw‹\paragraph{Total Correctness}›
text ‹
  Now, we reformulate our program to use a total correct while loop,
  and annotate the invariant at the loop. The invariant is strengthened by
  stating that the set of elements is finite.
›

definition "sum_max'_invar V0 σ  
  sum_max_invar V0 σ 
   (let (V,_,_)=σ in finite (V0-V))"

definition sum_max' :: "nat set  (nat×nat) nres" where
  "sum_max' V  do {
    (_,s,m)  WHILETsum_max'_invar V (λ(V,s,m). V{}) (λ(V,s,m). do {
      xSPEC (λx. xV); 
      let V=V-{x};
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"


theorem sum_max'_correct:
  assumes NE: "V{}" and FIN: "finite V"
  shows "sum_max' V  SPEC (λ(s,m). s=V  m=Max V)"
  using NE FIN unfolding sum_max'_def
  apply (intro refine_vcg) ― ‹Invoke vcg›

  txt ‹This time, the verification condition generator uses the annotated
    invariant. Moreover, it leaves us with a variant. We have to specify a 
    well-founded relation, and show that the loop body respects this
    relation. In our case, the set V› decreases in each step, and
    is initially finite. We use the relation @{const "finite_psubset"} and the
    @{const "inv_image"} combinator from the Isabelle/HOL standard library.›
  apply (subgoal_tac "wf (inv_image finite_psubset fst)",
    assumption) ― ‹Instantiate variant›
  apply simp ― ‹Show variant well-founded›

  unfolding sum_max'_invar_def ― ‹Unfold definition of invariant›
  apply (auto intro: sum_max_invar_step) ― ‹Discharge step›

  unfolding sum_max_invar_def ― ‹Unfold definition of invariant completely›
  apply (auto intro: finite_subset) ― ‹Discharge remaining goals›
  done

subsection ‹Refinement›
text ‹
  The next step in the program development is to refine the initial program
  towards an executable program. This usually involves both, program refinement
  and data refinement. Program refinement means changing the structure of the 
  program. Usually, some specification statements are replaced by more concrete
  implementations. Data refinement means changing the used data types towards
  implementable data types. 

  In our example, we implement the set V› with a distinct list,
  and replace the specification statement @{term "SPEC (λx. xV)"} by
  the head operation on distinct lists. For the lists, we use
  the list-set data structure provided by the Isabelle Collection Framework
  \cite{L09_collections,LL10}.

  For this example, we write the refined program ourselves.
  An automation of this task can be achieved with the automatic refinement tool,
  which is available as a prototype in Refine-Autoref. Usage examples are in
  ex/Automatic-Refinement. 
›

definition sum_max_impl :: "nat ls  (nat×nat) nres" where
  "sum_max_impl V  do {
    (_,s,m)  WHILE (λ(V,s,m). ¬ls.isEmpty V) (λ(V,s,m). do {
      xRETURN (the (ls.sel V (λx. True)));
      let V=ls.delete x V;
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

text ‹
  Note that we replaced the operations on sets by the respective operations
  on lists (with the naming scheme ls.xxx›). The specification 
  statement was replaced by @{term "the (ls.sel V (λx. True))"}, i.e.,
  selection of an element that satisfies the predicate @{term "(λx. True)"}.
  As @{const "ls.sel"} returns an option datatype, we extract the value with
  @{const "the"}. Moreover, we omitted the loop invariant, as we don't need it
  any more.
›

text ‹
  Next, we have to show that our concrete pogram actually refines
  the abstract one.
›
theorem sum_max_impl_refine: 
  assumes "(V,V')build_rel ls.α ls.invar" 
  shows "sum_max_impl V  Id (sum_max V')"
  txt ‹
    Let R› be a
    {\em refinement relation\footnote{Also called coupling invariant.}},
    that relates concrete and abstract values. 
  
    Then, the function @{term "R"} maps a result-set over abstract values to
    the greatest result-set over concrete values that is compatible 
    w.r.t.\ R›. The value @{const "FAIL"} is mapped to itself.

    Thus, the proposition @{term "S  R S'"} means, that S› refines
    S'› w.r.t.\ R›, i.e., every value in the result of 
    S› can be abstracted to a value in the result of S'›.
    
    Usually, the refinement relation consists of an invariant I› and
    an abstraction function α›. In this case, we may use the
    @{term "build_rel I α"}-function to define the refinement relation.
    
    In our example, we assume that the input is in the refinement relation 
    specified by list-sets, and show that the output is in the identity 
    relation. We use the identity here, as we do not change the datatypes of 
    the output.
›

  txt ‹The proof is done automatically by the refinement verification 
    condition generator.
    Note that the theory Collection_Bindings› sets up all the 
    necessary lemmas to discharge refinement conditions for the collection
    framework.›
  using assms unfolding sum_max_impl_def sum_max_def
  apply (refine_rcg) ― ‹Decompose combinators, generate data refinement goals›

  apply (refine_dref_type) ― ‹Type-based heuristics to instantiate data 
    refinement goals›
  apply (auto simp add: 
    ls.correct refine_hsimp refine_rel_defs) ― ‹Discharge proof obligations›
  done

text ‹
  Refinement is transitive, so it is easy to show that the concrete
  program meets the specification.
›
theorem sum_max_impl_correct:
  assumes "(V,V')build_rel ls.α ls.invar" and "V'{}"
  shows "sum_max_impl V  SPEC (λ(s,m). s=V'  m=Max V')"
proof -
  note sum_max_impl_refine
  also note sum_max_correct
  finally show ?thesis using assms .
qed

text ‹
  Just for completeness, we also refine the total correct program in the
  same way. 
›
definition sum_max'_impl :: "nat ls  (nat×nat) nres" where
  "sum_max'_impl V  do {
    (_,s,m)  WHILET (λ(V,s,m). ¬ls.isEmpty V) (λ(V,s,m). do {
      xRETURN (the (ls.sel V (λx. True)));
      let V=ls.delete x V;
      let s=s+x;
      let m=max m x;
      RETURN (V,s,m)
    }) (V,0,0);
    RETURN (s,m)
  }"

theorem sum_max'_impl_refine: 
  "(V,V')build_rel ls.α ls.invar  sum_max'_impl V  Id (sum_max' V')"
  unfolding sum_max'_impl_def sum_max'_def
  apply refine_rcg
  apply refine_dref_type
  apply (auto simp: refine_hsimp ls.correct refine_rel_defs)
  done

theorem sum_max'_impl_correct:
  assumes "(V,V')build_rel ls.α ls.invar" and "V'{}"
  shows "sum_max'_impl V  SPEC (λ(s,m). s=V'  m=Max V')"
  using ref_two_step[OF sum_max'_impl_refine sum_max'_correct] assms
  txt ‹Note that we do not need the finiteness precondition, as list-sets are
    always finite. However, in order to exploit this, we have to
    unfold the build_rel› construct, that relates the list-set on
    the concrete side to the set on the abstract side.
›
  apply (auto simp: build_rel_def)
  done

subsection ‹Code Generation›
text ‹
  In order to generate code from the above definitions,
  we convert the function defined in our monad to an ordinary, deterministic
  function, for that the Isabelle/HOL code generator can generate code.

  For partial correct algorithms, we can generate code inside a deterministic
  result monad. The domain of this monad is a flat complete lattice, where
  top means a failed assertion and bottom means nontermination. (Note that 
  executing a function in this monad will never return bottom, 
  but just diverge).
  The construct @{term "nres_of x"} embeds the deterministic into the
  nondeterministic monad. 

  Thus, we have to construct a function ?sum_max_code› such that:
›
schematic_goal sum_max_code_aux: "nres_of ?sum_max_code  sum_max_impl V"
  txt ‹This is done automatically by the transfer procedure of
    our framework.›
  unfolding sum_max_impl_def
  apply (refine_transfer)
  done

text ‹
  In order to define the function from the above lemma, we can use the
  command concrete_definition›, that is provided by our framework:
›
concrete_definition sum_max_code for V uses sum_max_code_aux

text ‹This defines a new constant sum_max_code›:›
thm sum_max_code_def
text ‹And proves the appropriate refinement lemma:›
thm sum_max_code.refine

text ‹Note that the concrete_definition› command is sensitive to
  patterns of the form RETURN _› and nres_of›, in which case
  the defined constant will not contain the RETURN› 
  or nres_of›. In any other case, the defined constant will just be 
  the left hand side of the refinement statement.
›

text ‹Finally, we can prove a correctness statement that is independent
  from our refinement framework:›
theorem sum_max_code_correct: 
  assumes "ls.α V  {}"
  shows "sum_max_code V = dRETURN (s,m)  s=(ls.α V)  m=Max (ls.α V)"
    and "sum_max_code V  dFAIL"
  txt ‹The proof is done by transitivity, and unfolding some 
    definitions:›
  using nres_correctD[OF order_trans[OF sum_max_code.refine sum_max_impl_correct,
    of V "ls.α V"]] assms
  by (auto simp: refine_rel_defs)
 

text ‹For total correctness, the approach is the same. The 
  only difference is, that we use @{const "RETURN"} instead 
  of @{const "nres_of"}:›
schematic_goal sum_max'_code_aux: 
  "RETURN ?sum_max'_code  sum_max'_impl V"
  unfolding sum_max'_impl_def
  apply (refine_transfer)
  done

concrete_definition sum_max'_code for V uses sum_max'_code_aux

theorem sum_max'_code_correct: 
  "ls.α V  {}  sum_max'_code V = ((ls.α V), Max (ls.α V))"
  using order_trans[OF sum_max'_code.refine sum_max'_impl_correct,
    of V "ls.α V"]
  by (auto simp: refine_rel_defs)

text ‹
  If we use recursion combinators, a plain function can only be generated,
  if the recursion combinators can be defined. Alternatively, for total correct
  programs, we may generate a (plain) function that internally uses the 
  deterministic monad, and then extracts the result.
›

schematic_goal sum_max''_code_aux: 
  "RETURN ?sum_max''_code  sum_max'_impl V"
  unfolding sum_max'_impl_def
  apply (refine_transfer the_resI) ― ‹Using @{text "the_resI"} for internal monad and result extraction›
  done

concrete_definition sum_max''_code for V uses sum_max''_code_aux

theorem sum_max''_code_correct: 
  "ls.α V  {}  sum_max''_code V = ((ls.α V), Max (ls.α V))"
  using order_trans[OF sum_max''_code.refine sum_max'_impl_correct,
    of V "ls.α V"]
  by (auto simp: refine_rel_defs)


text ‹Now, we can generate verified code with the Isabelle/HOL code
  generator:›
export_code sum_max_code sum_max'_code sum_max''_code checking SML
export_code sum_max_code sum_max'_code sum_max''_code checking OCaml?
export_code sum_max_code sum_max'_code sum_max''_code checking Haskell?
export_code sum_max_code sum_max'_code sum_max''_code checking Scala

subsection ‹Foreach-Loops›
text ‹
  In the sum_max› example above, we used a while-loop to iterate over
  the elements of a set. As this pattern is used commonly, there is
  an abbreviation for it in the refinement framework. The construct 
  @{term "FOREACH S f σ0"} iterates f::'x⇒'s⇒'s› for each element 
  in S::'x set›, starting with state σ0::'s›.
  
  With foreach-loops, we could have written our example as follows:
›

definition sum_max_it :: "nat set  (nat×nat) nres" where
  "sum_max_it V  FOREACH V (λx (s,m). RETURN (s+x,max m x)) (0,0)"

theorem sum_max_it_correct:
  assumes PRE: "V{}" and FIN: "finite V" 
  shows "sum_max_it V  SPEC (λ(s,m). s=V  m=Max V)"
  using PRE unfolding sum_max_it_def
  apply (intro FOREACH_rule[where I="λit σ. sum_max_invar V (it,σ)"] refine_vcg)
  apply (rule FIN) ― ‹Discharge finiteness of iterated set›
  apply (auto intro: sum_max_invar_step) ― ‹Discharge step›
  unfolding sum_max_invar_def ― ‹Unfold invariant definition›
  apply (auto) ― ‹Discharge remaining goals›
  done

definition sum_max_it_impl :: "nat ls  (nat×nat) nres" where
  "sum_max_it_impl V  FOREACH (ls.α V) (λx (s,m). RETURN (s+x,max m x)) (0,0)"
text ‹Note: The nondeterminism for iterators is currently resolved at
  transfer phase, where they are replaced by iterators from the ICF.›

lemma sum_max_it_impl_refine: 
  notes [refine] = inj_on_id
  assumes "(V,V')build_rel ls.α ls.invar" 
  shows "sum_max_it_impl V  Id (sum_max_it V')"
  unfolding sum_max_it_impl_def sum_max_it_def
  txt ‹Note that we specified inj_on_id› as additional introduction 
    rule. This is due to the very general iterator refinement rule, that may
    also change the set over that is iterated.›
  using assms
  apply refine_rcg ― ‹This time, we don't need the 
    @{text "refine_dref_type"} heuristics, as no schematic refinement 
    relations are generated.›
  apply (auto simp: refine_hsimp refine_rel_defs)
  done

schematic_goal sum_max_it_code_aux: 
  "RETURN ?sum_max_it_code  sum_max_it_impl V"
  unfolding sum_max_it_impl_def
  apply (refine_transfer)
  done

text ‹Note that the transfer method has replaced the iterator by an iterator
  from the Isabelle Collection Framework.›

thm sum_max_it_code_aux
concrete_definition sum_max_it_code for V uses sum_max_it_code_aux

theorem sum_max_it_code_correct: 
  assumes "ls.α V  {}" 
  shows "sum_max_it_code V = ((ls.α V), Max (ls.α V))" 
proof -
  note sum_max_it_code.refine[of V]
  also note sum_max_it_impl_refine[of V "ls.α V"]
  also note sum_max_it_correct
  finally show ?thesis using assms by (auto simp: refine_rel_defs)
qed

export_code sum_max_it_code checking SML
export_code sum_max_it_code checking OCaml?
export_code sum_max_it_code checking Haskell?
export_code sum_max_it_code checking Scala

definition "sum_max_it_list  sum_max_it_code o ls.from_list"
ML_val @{code sum_max_it_list} (map @{code nat_of_integer} [1,2,3,4,5])


section ‹Pointwise Reasoning›

text ‹
  In this section, we describe how to use pointwise reasoning to prove
  refinement statements and other relations between element of the 
  nondeterminism monad.

  Pointwise reasoning is often a powerful tool to show refinement between
  structurally different program fragments.
›

text ‹
  The refinement framework defines the predicates 
  @{const "nofail"} and @{const "inres"}.
  @{term "nofail S"} states that S› does not fail,
  and @{term "inres S x"} states that one possible result of S› is
  x› (Note that this includes the case that S› fails).

  Equality and refinement can be stated using @{const "nofail"} and 
  @{const "inres"}:
  @{thm [display] pw_eq_iff}
  @{thm [display] pw_le_iff}

  Useful corollaries of this lemma are 
  @{thm [source] pw_leI}, @{thm [source] pw_eqI}, and @{thm [source] pwD}.

  Once a refinement has been expressed via nofail/inres, the simplifier can be
  used to propagate the nofail and inres predicates inwards over the structure
  of the program. The relevant lemmas are contained in the named theorem 
  collection refine_pw_simps›.

  As an example, we show refinement of two structurally different programs here,
  both returning some value in a certain range:
›
lemma "do { ASSERT (fst p > 2); SPEC (λx. x(2::nat)*(fst p + snd p)) }
   do { let (x,y)=p; zSPEC (λz. zx+y); 
          aSPEC (λa. ax+y); ASSERT (x>2); RETURN (a+z)}"
  apply (rule pw_leI)
  apply (auto simp add: refine_pw_simps split: prod.split)

  apply (rename_tac a b x)
  apply (case_tac "xa+b")
  apply (rule_tac x=0 in exI)
  apply simp
  apply (rule_tac x="a+b" in exI)
  apply (simp)
  apply (rule_tac x="x-(a+b)" in exI)
  apply simp
  done

section "Arbitrary Recursion (TBD)"
text ‹
  While-loops are suited to express tail-recursion.
  In order to express arbitrary recursion, the refinement framework provides
  the nrec-mode for the partial_function› command, as well as the fixed 
  point combinators @{const "REC"} (partial correctness) and 
  @{const "RECT"} (total correctness).

  Examples for partial_function› can be found in 
  ex/Refine_Fold›. Examples for the recursion combinators can be found
  in ex/Recursion› and ex/Nested_DFS›.
›

section ‹Reference›
  subsection ‹Statements› text_raw ‹\label{sec:stmt_ref}›
  text ‹
    \begin{description}
      \item[@{const "SUCCEED"}] The empty set of results. Least element of
        the refinement ordering.
      \item[@{const "FAIL"}] Result that indicates a failing assertion.
        Greatest element of the refinement ordering.
      \item{@{term "RES X"}} All results from set X›.
      \item[@{term "RETURN x"}] Return single result x›. Defined in 
        terms of RES›: @{lemma "RETURN x = RES {x}" by simp}.
      \item[@{term "EMBED r"}] Embed partial-correctness option type, i.e.,
        succeed if r=None›, otherwise return value of r›.
      \item[@{term "SPEC Φ"}] Specification. 
        All results that satisfy predicate Φ›. Defined in terms of
        @{term "RES"}: @{lemma "SPEC Φ = RES (Collect Φ)" by simp}
      \item[@{term [source] "bind M f"}] Binding. 
        Nondeterministically choose a result from 
        M› and apply f› to it. Note that usually the 
        do›-notation is used, i.e., do {x←M; f x}› or
        do {M;f}› if the result of M› is not important.
        If M› fails, @{term [source] "bind M f"} also fails.
      \item[@{term "ASSERT Φ"}] Assertion. Fails
        if Φ› does not hold, otherwise returns ()›.
        Note that the default usage with the do-notation is: 
        @{term [source] "do {ASSERT Φ; f}"}.

      \item[@{term "ASSUME Φ"}] Assumption. Succeeds
        if Φ› does not hold, otherwise returns ()›. Note that
        the default usage with the do-notation is: 
        @{term [source] "do {ASSUME Φ; f}"}.

      \item[@{term "REC body"}] Recursion for partial correctness. 
        May be used to express arbitrary recursion. Returns SUCCEED› on
        nontermination.
      \item[@{term "RECT body"}] Recursion for total correctness. 
        Returns FAIL› on nontermination.
      \item[@{term "WHILE b f σ0"}] Partial correct while-loop. 
        Start with state σ0,
        and repeatedly apply f› as long as b› holds for the
        current state. Non-terminating paths are ignored, i.e., they do not
        contribute a result.
      \item[@{term "WHILET b f σ0"}] Total correct while-loop. If there is a
        non-terminating path, the result is @{term "FAIL"}.
      \item[@{term "WHILEI b f σ0"}, @{term "WHILETI b f σ0"}] While-loop with
        annotated invariant. It is asserted that the invariant holds.
      \item[@{term "FOREACH S f σ0"}] Foreach loop.
        Start with state σ0, and transform
        the state with f x› for each element x∈S›. Asserts that 
        S› is finite.
      \item[@{term "FOREACHI S f σ0"}] Foreach-loop with 
        annotated invariant. 

        Alternative syntax: @{term "FOREACHi I S f σ0"}.

        The invariant is a predicate of type
        I::'a set ⇒ 'b ⇒ bool›, where I it σ› means, that
        the invariant holds for the remaining set of elements it› and
        current state σ›. 
      \item[@{term "FOREACHC S c f σ0"}] Foreach-loop with explicit continuation 
        condition.

        Alternative syntax: @{term "FOREACHc S c f σ0"}.

        If c::'σ⇒bool› becomes false for the current state,
        the iteration immediately terminates.
      \item[@{term "FOREACHCI S c f σ0"}] Foreach-loop with explicit continuation 
        condition and annotated invariant.

        Alternative syntax: @{term "FOREACHci I S c f σ0"}.
      \item[partial_function (nrec)›] Mode of the partial function 
        package for the nondeterminism monad.
    \end{description}
›

    subsection ‹Refinement›
    text ‹
      \begin{description}
        \item{@{term_type "(≤) :: 'a nres  'a nres  bool"}} 
          Refinement ordering.
          S ≤ S'› means, that every result in 
          S› is also a result in S'›. 
          Moreover, S› may only fail if S'› fails.
          ≤› forms a complete lattice, with least element 
          SUCCEED› and greatest element FAIL›.
        \item{@{term "R"}} Concretization. Takes a refinement relation
          R::('c×'a) set› that relates concrete to abstract values, 
          and returns a concretization function 
          @{term "R :: 'a nres  'c nres"}.
        \item{@{term "R"}} Abstraction. Takes a refinement relation and
          returns an abstraction function. 
          The functions ⇓R› and ⇑R› form a Galois-connection,
          i.e., we have: S ≤ ⇓R S' ⟷ ⇑R S ≤ S'›.
        \item{@{term "build_rel α I"}} Builds a refinement relation from
          an abstraction function and an invariant. Those refinement relations
          are always single-valued.
        \item{@{term "nofail S"}} Predicate that states that S› does
          not fail.
        \item{@{term "inres S x"}} Predicate that states that S› 
          includes result x›. Note that a failing program includes all
          results.
      \end{description}
›


    subsection‹Proof Tools›
      text ‹
        \begin{description}
          \item{Verification Condition Generator:}
            \begin{description}
              \item[Method:] intro refine_vcg›
              \item[Attributes:] refine_vcg›
            \end{description}

            Transforms a subgoal of the
            form S ≤ SPEC Φ› into verification conditions by 
            decomposing the structure of S›. Invariants for loops 
            without annotation must be specified explicitely by instantiating
            the respective proof-rule for the loop construct, e.g., 
            intro WHILE_rule[where I=…] refine_vcg›.

            refine_vcg› is a named theorems collection that contains
            the rules that are used by default.

          \item{Refinement Condition Generator:}
            \begin{description}
              \item[Method:] refine_rcg› [thms]. 
              \item[Attributes:] refine0›, refine›, 
                refine2›.
              \item[Flags:] refine_no_prod_split›.
            \end{description}
            Tries to prove a subgoal of the form S ≤ ⇓R S'› by 
            decomposing the structure of S› and S'›. 
            The rules to be used are contained in the theorem collection 
            refine›. More rules may be passed as argument to the method.
            Rules contained in refine0› are always 
            tried first, and rules in refine2› are tried last. 
            Usually, rules that decompose both programs equally
            should be put into refine›. Rules that may make big steps,
            without decomposing the program further, should be put into
            refine0› (e.g., @{thm [source] Id_refine}). Rules that 
            decompose the programs differently and shall be used as last resort
            before giving up should be put into refine2›, e.g., 
            @{thm [source] remove_Let_refine}.

            By default, this procedure will invoke the splitter to split
            product types in the goals. This behaviour can be disabled by
            setting the flag refine_no_prod_split›.
          \item{Refinement Relation Heuristics:}
            \begin{description}
              \item[Method:] refine_dref_type› [(trace)].
              \item[Attributes:] refine_dref_RELATES›,  
                refine_dref_pattern›.
              \item[Flags:] refine_dref_tracing›.
            \end{description}
            Tries to instantiate schematic refinement relations based on their
            type. By default, this rule is applied to all subgoals. 
            Internally, it uses the rules declared as 
            refine_dref_pattern› to introduce a goal of the form
            RELATES ?R›, that is then solved by exhaustively 
            applying rules declared as refine_dref_RELATES›.
            
            The flag refine_dref_tracing› controls tracing of 
            resolving RELATES›-goals. Tracing may also be enabled by
            passing (trace) as argument.

          \item{Pointwise Reasoning Simplification Rules:}
            \begin{description}
              \item[Attributes:] refine_pw_simps›
            \end{description}
            A theorem collection that contains 
            simplification lemmas to push inwards @{term "nofail"} and
            @{term "inres"} predicates into program constructs.

          \item{Refinement Simp Rules:}
            \begin{description}
              \item[Attributes:] refine_hsimp›
            \end{description}
            A theorem collection that contains some
            simplification lemmas that are useful to prove membership in 
            refinement relations.

          \item{Transfer:}
            \begin{description}
              \item[Method:] refine_transfer› [thms] 
              \item[Attribute:] refine_transfer›
            \end{description}
            Tries to prove a subgoal of the form α f ≤ S› by 
            decomposing the structure of f› and S›. 
            This is usually used in connection
            with a schematic lemma, to generate f› from the structure
            of S›.

            The theorems declared as refine_transfer› are used to do
            the transfer. More theorems may be passed as arguments to the method. 
            Moreover, some simplification for nested abstraction 
            over product types (λ(a,b) (c,d). …›) is done, and the
            monotonicity prover is used on monotonicity goals.

            There is a standard setup for α=RETURN› 
            (transfer to plain function for total correct code generation), and
            α=nres_of› (transfer to deterministic result monad, for 
            partial correct code generation).

          \item{Automatic Refinement:}
            \begin{description}
              \item[Method:] refine_autoref› 
              \item[Attributes:] ...
            \end{description}
            See automatic refinement package for documentation (TBD)

          \item{Concrete Definition:}
            \begin{description}
              \item[Command:] 
               concrete_definition name [attribs] for params uses thm›
               where attribs› and the for›-part are optional.

               Declares a new constant from the left-hand side of a refinement
               lemma. Has special handling for left-hand sides of the forms 
               RETURN _› and nres_of›, in which cases those 
               topmost functions are not included in the defined constant.

               The refinement lemma is folded with the new constant and 
               registered as name.refine›.
              \item[Command:]
              prepare_code_thms thms› takes a list of definitional 
                theorems and sets up lemmas for the code generator for those 
                definitions. This includes handling of recursion combinators.
            \end{description}
        \end{description}
›


    subsection‹Packages› 
      text ‹
        The following parts of the refinement framework are not included
        by default, but can be imported if necessary:
        \begin{description}
          \item{Collection-Bindings:} Sets up refinement rules for the 
            Isabelle Collection Framework. With this theory loaded, the
            refinement condition generator will discharge most data refinements
            using the ICF automatically. Moreover, the transfer procedure
            will replace FOREACH›-statements by the corresponding 
            ICF-iterators.
        \end{description}
›

end

Theory ICF_Userguide

(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*<*)
theory ICF_Userguide
imports 
  "../ICF/Collections"
  "../Lib/Code_Target_ICF"
begin
(*>*)

text_raw ‹\isasection{Isabelle Collections Framework Userguide}\label{thy:Userguide}›


section "Introduction"
text ‹
  This is the Userguide for the (old) Isabelle Collection Framework.
  It does not cover the Generic Collection Framework, nor the 
  Automatic Refinement Framework.

  The Isabelle Collections Framework defines interfaces of various collection types and provides some standard implementations and generic algorithms.

  The relation between the data structures of the collection framework and standard Isabelle types (e.g. for sets and maps) is established by abstraction functions.

  Amongst others, the following interfaces and data-structures are provided by the Isabelle Collections Framework (For a complete list, see the overview section
  in the implementations chapter of the proof document):
  \begin{itemize}
    \item Set and map implementations based on (associative) lists, red-black trees, hashing and tries.
    \item An implementation of a FIFO-queue based on two stacks.
    \item Annotated lists implemented by finger trees.
    \item Priority queues implemented by binomial heaps, skew binomial heaps, and annotated lists (via finger trees).
  \end{itemize}

  The red-black trees are imported from the standard isabelle library. The binomial and skew binomial heaps are
  imported from the {\em Binomial-Heaps} entry of the archive of formal proofs. The finger trees are imported from
  the {\em Finger-Trees} entry of the archive of formal proofs.
›

subsection "Getting Started"
text ‹
  To get started with the Isabelle Collections Framework (assuming that you are already familiar with Isabelle/HOL and Isar),
  you should first read the introduction (this section), that provides many basic examples. More examples are in the examples/ subdirectory of the collection
  framework.
  Section~\ref{sec:userguide.structure} explains the concepts of the Isabelle Collections Framework in more detail.
  Section~\ref{sec:userguide.ext} provides information on extending the framework along with detailed examples, and 
  Section~\ref{sec:userguide.design} contains a discussion on the design of this framework.
  There is also a paper \cite{LammichLochbihler2010ITP} on the design of the Isabelle Collections Framework available.
›

subsection "Introductory Example"
text ‹
  We introduce the Isabelle Collections Framework by a simple example.

  Given a set of elements represented by a red-black tree, and a list, 
  we want to filter out all elements that are not contained in the set. 
  This can be done by Isabelle/HOL's @{const filter}-function\footnote{Note that Isabelle/HOL uses the list comprehension syntax @{term [source] "[xl. P x]"}
  as syntactic sugar for filtering a list.}:
›

definition rbt_restrict_list :: "'a::linorder rs  'a list  'a list"
where "rbt_restrict_list s l == [ xl. rs.memb x s ]"

text ‹
  The type @{typ "'a rs"} is the type of sets backed by red-black trees.
  Note that the element type of sets backed by red-black trees must be
  of sort linorder›.
  The function @{const rs.memb} tests membership on such sets.
›  

text ‹Next, we show correctness of our function:›
lemma rbt_restrict_list_correct: 
  assumes [simp]: "rs.invar s"
  shows "rbt_restrict_list s l = [xl. xrs.α s]"
  by (simp add: rbt_restrict_list_def rs.memb_correct)

text ‹
  The lemma @{thm [source] rs.memb_correct}: @{thm [display] rs.memb_correct[no_vars]} 

  states correctness of the @{const rs.memb}-function. 
  The function @{const rs.α} maps a red-black-tree to the set that it represents.
  Moreover, we have to explicitely keep track of the invariants of the used data structure,
  in this case red-black trees. 
  The premise @{thm (prem 1) rs.memb_correct} represents the invariant assumption for the collection data structure.
  Red-black-trees are invariant-free, so this defaults to @{term "True"}.
  For uniformity reasons, these (unnecessary) invariant assumptions are present in all correctness lemmata.

  Many of the correctness lemmas for standard RBT-set-operations are summarized by the lemma @{thm [source] rs.correct}:
    @{thm [display] rs.correct[no_vars]}

text ‹
  All implementations provided by this library are compatible with the Isabelle/HOL code-generator.
  Now follow some examples of using the code-generator.
  Note that the code generator can only generate code for plain constants 
  without arguments, while the operations like @{const rs.memb} have arguments,
  that are only hidden by an abbreviation.
›

text ‹
  There are conversion functions from lists to sets and, vice-versa, from sets to lists:
›

definition "conv_tests  (
  rs.from_list [1::int .. 10],
  rs.to_list (rs.from_list [1::int .. 10]),
  rs.to_sorted_list (rs.from_list [1::int,5,6,7,3,4,9,8,2,7,6]),
  rs.to_rev_list (rs.from_list [1::int,5,6,7,3,4,9,8,2,7,6])
)"

ML_val @{code conv_tests}

text ‹
  Note that sets make no guarantee about ordering, hence the only thing we can 
  prove about conversion from sets to lists is:
    @{thm [source] rs.to_list_correct}: @{thm [display] rs.to_list_correct[no_vars]}

  Some sets, like red-black-trees, also support conversion to sorted lists,
  and we have:
    @{thm [source] rs.to_sorted_list_correct}: @{thm [display] rs.to_sorted_list_correct[no_vars]} and
    @{thm [source] rs.to_rev_list_correct}: @{thm [display] rs.to_rev_list_correct[no_vars]}

definition "restrict_list_test  rbt_restrict_list (rs.from_list [1::nat,2,3,4,5]) [1::nat,9,2,3,4,5,6,5,4,3,6,7,8,9]"

ML_val @{code restrict_list_test}

definition "big_test n = (rs.from_list [(1::int)..n])"

ML_val @{code big_test} (@{code int_of_integer} 9000)

subsection "Theories"
text ‹
  To make available the whole collections framework to your formalization, 
  import the theory @{theory Collections.Collections} which includes everything. Here is a
  small selection:
  \begin{description}
    \item[@{theory Collections.SetSpec}] Specification of sets and set functions
    \item[@{theory Collections.SetGA}] Generic algorithms for sets
    \item[@{theory Collections.SetStdImpl}] Standard set implementations (list, rb-tree, hashing, tries)
    \item[@{theory Collections.MapSpec}] Specification of maps
    \item[@{theory Collections.MapGA}] Generic algorithms for maps
    \item[@{theory Collections.MapStdImpl}] Standard map implementations (list,rb-tree, hashing, tries)
    \item[@{theory Collections.ListSpec}] Specification of lists
    \item[@{theory Collections.Fifo}] Amortized fifo queue
    \item[@{theory Collections.DatRef}] Data refinement for the while combinator
  \end{description}

›

subsection "Iterators"
text ‹An important concept when using collections are iterators. An iterator is a kind of generalized fold-functional.
  Like the fold-functional, it applies a function to all elements of a set and modifies a state. There are
  no guarantees about the iteration order. But, unlike the fold functional, you can prove useful properties of iterations
  even if the function is not left-commutative. Proofs about iterations are done in invariant style, establishing an
  invariant over the iteration.

  The iterator combinator for red-black tree sets is @{const rs.iterate}, and the proof-rule that is usually used is:
    @{thm [source] rs.iteratei_rule_P}: @{thm [display] rs.iteratei_rule_P[no_vars]}

  The invariant @{term I} is parameterized with the set of remaining elements that have not yet been iterated over and the
  current state. The invariant has to hold for all elements remaining and the initial state: @{term "I (rs.α S) σ0"}. 
  Moreover, the invariant has to be preserved by an iteration step: 
    @{term [display] "x it σ. x  it; it  rs.α S; I it σ  I (it - {x}) (f x σ)"}
  And the proposition to be shown for the final state must be a consequence of the invarant for no 
  elements remaining: @{term "σ. I {} σ  P σ"}. 

  A generalization of iterators are {\em interruptible iterators} where iteration is only continues while some condition on the state holds.
  Reasoning over interruptible iterators is also done by invariants: 
    @{thm [source] rs.iteratei_rule_P}: @{thm [display] rs.iteratei_rule_P[no_vars]}

  Here, interruption of the iteration is handled by the premise
    @{term [display] "σ it. it  rs.α S; it  {}; ¬ c σ; I it σ  P σ"}
  that shows the proposition from the invariant for any intermediate state of the 
  iteration where the continuation condition 
  does not hold (and thus the iteration is interrupted).
›

text ‹
  As an example of reasoning about results of iterators, we implement a function
  that converts a hashset to a list that contains precisely the elements of the set.
›

definition "hs_to_list' s == hs.iteratei s (λ_. True) (#) []"

text ‹
  The correctness proof works by establishing the invariant that the list contains
  all elements that have already been iterated over.
  Again @{term "hs.invar s"} denotes the invariant for hashsets which defaults to @{term "True"}.
›
lemma hs_to_list'_correct: 
  assumes INV: "hs.invar s"
  shows "set (hs_to_list' s) = hs.α s"
  apply (unfold hs_to_list'_def)
  apply (rule_tac 
    I="λit σ. set σ = hs.α s - it"
    in hs.iterate_rule_P[OF INV])
  txt ‹The resulting proof obligations are easily discharged using auto:›
  apply auto
  done

text ‹
  As an example for an interruptible iterator, 
  we define a bounded existential-quantification over the list elements.
  As soon as the first element is found that fulfills the predicate,
  the iteration is interrupted.
  The state of the iteration is simply a boolean, indicating the (current) result of the quantification:
›

definition "hs_bex s P == hs.iteratei s (λσ. ¬ σ) (λx σ. P x) False"

lemma hs_bex_correct: 
  "hs.invar s  hs_bex s P  (xhs.α s. P x)"
  apply (unfold hs_bex_def)
  txt ‹The invariant states that the current result matches the result of the quantification
    over the elements already iterated over:›
  apply (rule_tac 
    I="λit σ. σ  (xhs.α s - it. P x)" 
    in hs.iteratei_rule_P)
  txt ‹The resulting proof obligations are easily discharged by auto:›
  apply auto
  done


section "Structure of the Framework"
text_raw ‹\label{sec:userguide.structure}›
text ‹
  The concepts of the framework are roughly based on the object-oriented concepts of interfaces, implementations and generic algorithms.

  The concepts used in the framework are the following:
  \begin{description}
    \item[Interfaces] An interface describes some concept by providing an abstraction mapping $\alpha$ to a related Isabelle/HOL-concept.
      The definition is generic in the datatype used to implement the concept (i.e. the concrete data structure). An interface is specified by means 
      of a locale that fixes the abstraction mapping and an invariant.
      For example, the set-interface contains an abstraction mapping to sets, and is specified by the locale SetSpec.set›.
      An interface roughly matches the concept of a (collection) interface in Java, e.g. {\em java.util.Set}.
  
    \item[Functions] A function specifies some functionality involving interfaces. A function is specified by means of a locale.
                      For example, membership query for a set is specified by the locale @{const [source] SetSpec.set_memb} and
                      equality test between two sets is a function specified by @{const [source] SetSpec.set_equal}.
                      A function roughly matches a method declared in an interface, e.g. {\em java.util.Set\#contains, java.util.Set\#equals}.

    \item[Operation Records] In order to reference an interface with a standard
      set of operations, those operations are summarized in a record, and there 
      is a locale that fixes this record, and makes available all operations.
      For example, the locale @{const [source] SetSpec.StdSet} fixes a record
      of standard set operations and assumes their correctness. It also defines 
      abbreviations to easily access the members of the record. Internally,
      all the standard operations, like @{const hs.memb}, are introduced by
      interpretation of such an operation locale.

    \item[Generic Algorithms] A generic algorithm specifies, in a generic way,
      how to implement a function using other functions. Usually, a generic 
      algorithm lives in a locale that imports the necessary operation locales.
      For example, the locale @{const SetGA.cart_loc} defines a generic 
      algorithm for the cartesian product between two sets.

      There is no direct match of generic algorithms in the Java
      Collections Framework. The most related concept are abstract
      collection interfaces, that provide some default algorithms,
      e.g. {\em java.util.AbstractSet}.  The concept of {\em Algorithm} in
      the C++ Standard Template Library \cite{C++STL} matches the concept
      of Generic Algorithm quite well.


    \item[Implementation] An implementation of an interface provides a
       data structure for that interface together with an abstraction
       mapping and an invariant. Moreover, it provides implementations
       for some (or all) functions of that interface.  For example,
       red-black trees are an implementation of the set-interface,
       with the abstraction mapping @{const rs.α} and invariant
       @{const rs.invar}; and the constant @{const rs.ins} implements
       the insert-function, as can be verified by 
       @{lemma "set_ins rs.α rs.invar rs.ins" by unfold_locales}.
       An implementation matches a concrete collection
       interface in Java, e.g. {\em java.util.TreeSet}, and the
       methods implemented by such an interface, e.g. {\em
       java.util.TreeSet\#add}. 


    \item[Instantiation] An instantiation of a generic algorithm
        provides actual implementations for the used functions. For
        example, the generic cartesian-product algorithm can be
        instantiated to use red-black-trees for both arguments, and output
        a list, as will be illustrated below in Section~\ref{sec:inst_gen_algo}.
        While some of the functions
        of an implementation need to be implemented specifically, many
        functions may be obtained by instantiating generic algorithms.
        In Java, instantiation of a generic algorithm is matched most
        closely by inheriting from an abstract collection
        interface. In the C++ Standard Template Library instantiation
        of generic algorithms is done implicitely by the compiler.

  \end{description}

›


  subsection "Instantiation of Generic Algorithms" text_raw ‹\label{sec:inst_gen_algo}›
  
  text ‹A generic algorithm is instantiated by interpreting its locale with 
    the wanted implementations. For example, to obtain a cartesian product
    between two red-black trees, yielding a list, we can do the following:›
  setup Locale_Code.open_block
  interpretation rrl: cart_loc rs_ops rs_ops ls_ops by unfold_locales
  setup Locale_Code.close_block
  setup ICF_Tools.revert_abbrevs "rrl"

  text ‹It is then available under the expected name:›
  term "rrl.cart"

  text ‹Note the three lines of boilerplate code, that work around some 
    technical problems of Isabelle/HOL: The Locale_Code.open_block› and
    Locale_Code.close_block› commands set up code generation for any 
    locale that is interpreted in between them. They also have to be specified
    if an existing locale that already has interpretations is extended by
    new definitions.

    The ICF_Tools.revert_abbrevs "rrl"› reverts all 
    abbreviations introduced by the locale, such that the displayed 
    information becomes nicer.
›


  subsection "Naming Conventions"
  text ‹
    The Isabelle Collections Framework follows these general naming conventions.
    Each implementation has a two-letter (or three-letter) and a one-letter (or two-letter) abbreviation, that are used as prefixes for the related constants, lemmas and instantiations.

    The two-letter and three-letter abbreviations should be unique over all interfaces and instantiations, the one-letter abbreviations should be unique
    over all implementations of the same interface.
    Names that reference the implementation of only one interface are prefixed with that implementation's two-letter abbreviation (e.g. @{const hs.ins} for insertion into a HashSet (hs,h)),
    names that reference more than one implementation are prefixed with the one-letter (or two-letter) abbreviations (e.g. @{const rrl.cart} for the cartesian 
    product between two RBT-Sets, yielding a list-set)
    
    The most important abbreviations are:
    \begin{description}
      \item[lm,l] List Map
      \item[lmi,li] List Map with explicit invariant
      \item[rm,r] RB-Tree Map
      \item[hm,h] Hash Map
      \item[ahm,a] Array-based hash map
      \item[tm,t] Trie Map
      \item[ls,l] List Set
      \item[lsi,li] List Set with explicit invariant
      \item[rs,r] RB-Tree Set
      \item[hs,h] Hash Set
      \item[ahs,a] Array-based hash map
      \item[ts,t] Trie Set
    \end{description}

    Each function name› of an interface interface› is declared in a locale interface_name›. This locale provides a fact name_correct›. For example, there is the locale @{const set_ins} providing
    the fact @{thm [source] set_ins.ins_correct}.
    An implementation instantiates the locales of all implemented functions, using its two-letter abbreviation as instantiation prefix. For example, the HashSet-implementation instantiates the locale @{const set_ins} 
    with the prefix {\em hs}, yielding the lemma @{thm [source] hs.ins_correct}. Moreover, an implementation with two-letter abbreviation {\em aa} provides a lemma aa.correct› 
    that summarizes the correctness facts for the basic 
    operations. It should only contain those facts that are safe to be used with the simplifier. E.g., the correctness facts for basic operations on hash sets are available via the lemma @{thm [source] hs.correct}.

›

section "Extending the Framework"
text_raw ‹\label{sec:userguide.ext}›
text ‹
  The best way to add new features, i.e., interfaces, functions, 
  generic algorithms, or implementations to the collection framework is to use 
  one of the existing items as example. 
›


section "Design Issues"
text_raw ‹\label{sec:userguide.design}›
  text ‹
    In this section, we motivate some of the design decisions of the Isabelle Collections Framework and report our experience with alternatives.
    Many of the design decisions are justified by restrictions of Isabelle/HOL and the code generator, so that there may be better
    options if those restrictions should vanish from future releases of Isabelle/HOL.
›

  text ‹
    The main design goals of this development are:
    \begin{enumerate}
      \item\label{dg_unified} Make available various implementations of collections under a unified interface.
      \item\label{dg_extensible} It should be easy to extend the framework by new interfaces, functions, algorithms, and implementations.
      \item\label{dg_concise} Allow simple and concise reasoning over functions using collections.
      \item\label{dg_genalgo} Allow generic algorithms, that are independent of the actual data structure that is used.
      \item\label{dg_exec} Support generation of executable code.
      \item\label{dg_control} Let the user precisely control what data structures are used in the implementation.
    \end{enumerate}
›

  subsection ‹Data Refinement›
  text ‹
    In order to allow simple reasoning over collections, we use a data refinement approach. Each collection
    interface has an abstraction function that maps it on a related Isabelle/HOL concept (abstract level).
    The specification of functions are also relative to the abstraction.
    This allows most of the correctness reasoning to be done on the abstract level. On this level,
    the tool support is more elaborated and one is not yet fixed to a concrete implementation.
    In a next step, the abstract specification is refined to use an actual implementation (concrete level). The correctness properties
    proven on the abstract level usually transfer easily to the concrete level.

    Moreover, the user has precise control how the refinement is done, i.e. what data structures are used. An alternative would be to do refinement
    completely automatic, as e.g. done in the code generator setup of the Theory~{\em Executable-Set}. This has the advantage that it induces less writing overhead.
    The disadvantage is that the user looses a great amount of control over the refinement. For example, in {\em Executable-Set}, all sets have to be represented by lists,
    and there is no possibility to represent one set differently from another. 

    For a more detailed discussion of the data refinement issue, we refer to
    the monadic refinement framework, that is available in the AFP 
    (@{url "http://isa-afp.org/entries/Refine_Monadic.shtml"})
›

  subsection ‹Operation Records›
  text ‹
    In order to allow convenient access to the most frequently used functions 
    of an interface,
    we have grouped them together in a record, and defined a locale that only
    fixes this record. This greatly reduces the boilerplate required to define
    a new (generic) algorithm, as only the operation locale (instead of every
    single function) has to be included in the locale for the generic algorithm.

    Note however, that parameters of locales are monomorphic inside the locale.
    Thus, we have to import an own instance for the locale for every element
    type of a set, or key/value type of a map. 
    For iterators, where this problem was most annoying, we have installed a
    workaround that allows polymorphic iterators even inside locales.
›

  subsection ‹Locales for Generic Algorithms›
  text ‹
    A generic algorithm is defined within a locale, that includes the required 
    functions (or operation locales). If many instances of the same interface
    are required, prefixes are used to distinguish between them. This makes
    the code for a generic algorithm quite consise and readable.

    However, there are some technical issues that one has to consider:
    \begin{itemize}
      \item  When fixing parameters in the declaration of the locale, their
        types will be inferred independently of the definitions later done in
        the locale context. In order to get the correct types, one has to add 
        explicit type constraints.
      \item The code generator has problems with generating code from 
        definitions inside a locale. Currently, the Locale_Code›-package
        provides a rather convenient workaround for that issue: It requires the 
        user to enclose interpretations and definitions of new constants inside
        already interpreted locales within two special commands, that set up
        the code generator appropriately.
    \end{itemize}
›

  subsection ‹Explicit Invariants vs Typedef›
  text ‹
    The interfaces of this framework use explicit invariants.
    This provides a more general specification which allows some operations to
    be implemented more efficiently, cf. @{const "lsi.ins_dj"} 
    in @{theory Collections.ListSetImpl_Invar}.
    
    Most implementations, however, hide the invariant in a typedef and setup
    the code generator appropriately.
    In that case, the invariant is just @{term "λ_. True"}, and removed 
    automatically by the simplifier and classical reasoner.
    However, it still shows up in some premises and conclusions due to
    uniformity reasons.
›

(*<*)
end
(*>*)